cgit.sxemacs.org Git - sxemacs/blob - modules/cl/cl.c

   1 /*
   2   cl.c -- Common Lisp Goodness, the fast version
   3   Copyright (C) 2006, 2007 Sebastian Freundt
   4
   5   Author:  Sebastian Freundt <hroptatyr@sxemacs.org>
   6
   7   * This file is part of SXEmacs.
   8   *
   9   * Redistribution and use in source and binary forms, with or without
  10   * modification, are permitted provided that the following conditions
  11   * are met:
  12   *
  13   * 1. Redistributions of source code must retain the above copyright
  14   *    notice, this list of conditions and the following disclaimer.
  15   *
  16   * 2. Redistributions in binary form must reproduce the above copyright
  17   *    notice, this list of conditions and the following disclaimer in the
  18   *    documentation and/or other materials provided with the distribution.
  19   *
  20   * 3. Neither the name of the author nor the names of any contributors
  21   *    may be used to endorse or promote products derived from this
  22   *    software without specific prior written permission.
  23   *
  24   * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
  25   * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  26   * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  27   * DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  28   * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  29   * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  30   * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
  31   * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  32   * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
  33   * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
  34   * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  35   */
  36
  37 /* Synched up with: Not in FSF. */
  38
  39 #include <config.h>
  40 #include <sxemacs.h>
  41 #include "cl.h"
  42 #ifdef EMOD_CL_MONOMOD
  43 #include "cl-loop.h"
  44 #endif
  45
  46 PROVIDE(cl);
  47 #if !defined EMOD_CL_MONOMOD
  48 #define INIT    cl_LTX_init
  49 #define REINIT  cl_LTX_reinit
  50 #define DEINIT  cl_LTX_deinit
  51 #else
  52 #define INIT    cl_mono_LTX_init
  53 #define REINIT  cl_mono_LTX_reinit
  54 #define DEINIT  cl_mono_LTX_deinit
  55 #endif
  56
  57 \f
  58 /* ###autoload */
  59 DEFUN("cl:pop", Fcl_pop, 1, UNEVALLED, 0, /*
  60 */
  61       (args))
  62 {
  63         /* This function can GC */
  64         Lisp_Object place = XCAR(args);
  65         Lisp_Object result = Qnil;
  66         struct gcpro gcpro1, gcpro2;
  67
  68         GCPRO2(result, place);
  69
  70         if (SYMBOLP(place)) {
  71                 Lisp_Object ls;
  72                 ls = Fsymbol_value(place);
  73                 if (CONSP(ls)) {
  74                         result = XCAR(ls);
  75                         Fset(place, XCDR(ls));
  76                 }
  77         }
  78
  79         UNGCPRO;
  80         return result;
  81 }
  82
  83 /* ###autoload */
  84 DEFUN("cl:push", Fcl_push, 2, UNEVALLED, 0, /*
  85 */
  86       (args))
  87 {
  88         /* This function can GC */
  89         Lisp_Object x = XCAR(args);
  90         Lisp_Object place = XCAR(XCDR(args));
  91         Lisp_Object result = Qnil;
  92         struct gcpro gcpro1, gcpro2, gcpro3;
  93
  94         GCPRO3(result, x, place);
  95
  96         if (SYMBOLP(place)) {
  97                 Lisp_Object ls;
  98                 ls = Fsymbol_value(place);
  99                 x = Feval(x);
 100                 Fset(place, (result = Fcons(x, ls)));
 101         }
 102
 103         UNGCPRO;
 104         return result;
 105 }
 106
 107 /* ###autoload */
 108 DEFUN("cl:pushnew", Fcl_pushnew, 2, UNEVALLED, 0, /*
 109 */
 110       (args))
 111 {
 112         /* This function can GC */
 113         Lisp_Object x = XCAR(args);
 114         Lisp_Object place = XCAR(XCDR(args));
 115         Lisp_Object result = Qnil;
 116         struct gcpro gcpro1, gcpro2, gcpro3;
 117
 118         GCPRO3(result, x, place);
 119
 120         if (SYMBOLP(place)) {
 121                 Lisp_Object ls;
 122                 result = ls = Fsymbol_value(place);
 123                 if (0) {        /* !X_NOT_FOUND_IN_LS_P */
 124                         x = Feval(x);
 125                         Fset(place, (result = Fcons(x, ls)));
 126                 }
 127         }
 128
 129         UNGCPRO;
 130         return result;
 131 }
 132
 133 #define EMOD_CL_EQL(_a, _b)                                             \
 134         ((!FLOATP(_a)) ? (EQ((_a), (_b))) : (!NILP(Fequal((_a), (_b)))))
 135 static inline
 136 int emodcl_eql(Lisp_Object a, Lisp_Object b)
 137 {
 138         return EMOD_CL_EQL(a, b);
 139 }
 140
 141 /* ###autoload */
 142 DEFUN("cl:eql", Fcl_eql, 2, 2, 0, /*
 143 */
 144       (a, b))
 145 {
 146         if (EMOD_CL_EQL(a, b))
 147                 return Qt;
 148         else
 149                 return Qnil;
 150 }
 151
 152 /* ###autoload */
 153 DEFUN("cl:list*", Fcl_list_, 1, MANY, 0, /*
 154 */
 155       (int nargs, Lisp_Object *args))
 156 {
 157         if (nargs == 1)
 158                 return args[0];
 159         else {
 160                 Lisp_Object result = args[--nargs];
 161                 for (; nargs > 0; ) {
 162                         result = Fcons(args[--nargs], result);
 163                 }
 164                 return result;
 165         }
 166 }
 167
 168 /* ###autoload */
 169 DEFUN("cl:tailp", Fcl_tailp, 2, 2, 0, /*
 170 */
 171       (list, object))
 172 {
 173         Lisp_Object trav1 = Qnil, trav2 = Qnil;
 174
 175         CHECK_CONS(list);
 176
 177         if (CONSP(object)) {
 178                 trav2 = XCAR(object);
 179                 for (trav1 = list; CONSP(trav1); trav1 = XCDR(trav1)) {
 180                         if (EMOD_CL_EQL(XCAR(trav1), trav2))
 181                                 break;
 182                 }
 183                 if (!CONSP(trav1))
 184                         return Qnil;
 185
 186                 for (trav1 = XCDR(trav1), trav2 = XCDR(object);
 187                      CONSP(trav1) && CONSP(trav2);
 188                      trav1 = XCDR(trav1), trav2 = XCDR(trav2)) {
 189                         if (!EMOD_CL_EQL(XCAR(trav1), XCAR(trav2))) {
 190                                 return Qnil;
 191                         }
 192                 }
 193                 if (EMOD_CL_EQL(trav1, trav2))
 194                         return Qt;
 195                 else
 196                         return Qnil;
 197
 198         } else {
 199                 for (trav1 = list; CONSP(trav1); trav1 = XCDR(trav1));
 200                 if (EMOD_CL_EQL(trav1, object))
 201                         return Qt;
 202                 else
 203                         return Qnil;
 204         }
 205         return Qnil;
 206 }
 207
 208 /* ###autoload */
 209 DEFUN("cl:ldiff", Fcl_ldiff, 2, 2, 0, /*
 210 */
 211       (list, object))
 212 {
 213         Lisp_Object result = Qnil, tmp1 = Qnil, tmp2 = Qnil;
 214         Lisp_Object trav1 = Qnil, trav2 = Qnil;
 215         int yes;
 216
 217         CHECK_CONS(list);
 218
 219         if (CONSP(object)) {
 220                 trav2 = XCAR(object);
 221                 for (trav1 = list; CONSP(trav1); trav1 = XCDR(trav1)) {
 222                         if (EMOD_CL_EQL(XCAR(trav1), trav2))
 223                                 break;
 224                         tmp1 = Fcons(XCAR(trav1), tmp1);
 225                 }
 226                 /* we traversed list and haven't found a match yet */
 227                 if (!CONSP(trav1)) {
 228                         result = trav1;
 229                         goto build_result;
 230                 } else {
 231                         tmp2 = trav1;
 232                 }
 233
 234                 yes = 1;
 235                 for (trav1 = XCDR(trav1), trav2 = XCDR(object);
 236                      CONSP(trav1) && CONSP(trav2);
 237                      trav1 = XCDR(trav1), trav2 = XCDR(trav2)) {
 238                         if (yes && !EMOD_CL_EQL(XCAR(trav1), XCAR(trav2))) {
 239                                 yes = 0;
 240                         }
 241                 }
 242                 if (!yes || !EMOD_CL_EQL(trav1, trav2)) {
 243                         /* if not, just pump the rest */
 244                         for (trav1 = tmp2; CONSP(trav1); trav1 = XCDR(trav1)) {
 245                                 tmp1 = Fcons(XCAR(trav1), tmp1);
 246                         }
 247                         result = trav1;
 248                 }
 249         } else {
 250                 for (trav1 = list; CONSP(trav1); trav1 = XCDR(trav1))
 251                         tmp1 = Fcons(XCAR(trav1), tmp1);
 252                 if (!EMOD_CL_EQL(trav1, object))
 253                         result = trav1;
 254         }
 255
 256 build_result:
 257         /* push the head */
 258         for (trav1 = tmp1; CONSP(trav1); trav1 = XCDR(trav1)) {
 259                 result = Fcons(XCAR(trav1), result);
 260         }
 261
 262         return result;
 263 }
 264
 265 #if 0
 266 /* ###4utoload */
 267 D3FUN("cl:adjoin", Fcl_adjoin, 2, MANY, 0, /*
 268                                            */
 269       (int nargs, Lisp_Object *args))
 270 {
 271         return Qnil;
 272 }
 273 #endif  /* 0 */
 274
 275 \f
 276 /* simplified initialiser */
 277 void
 278 INIT(void)
 279 {
 280         DEFSUBR(Fcl_pop);
 281         DEFSUBR(Fcl_push);
 282         DEFSUBR(Fcl_pushnew);
 283
 284         DEFSUBR(Fcl_list_);
 285         DEFSUBR(Fcl_tailp);
 286         DEFSUBR(Fcl_ldiff);
 287
 288         DEFSUBR(Fcl_eql);
 289
 290 #if defined EMOD_CL_MONOMOD
 291         cl_loop_LTX_init();
 292 #endif
 293
 294         Fprovide(intern("cl"));
 295 }
 296
 297 void
 298 DEINIT(void)
 299 {
 300 }
 301
 302 void
 303 REINIT(void)
 304 {
 305         Frevoke(intern("cl"));
 306 }
 307
 308 /* cl.c ends here */