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 #include <ent/ent.h>
  47
  48 PROVIDE(cl);
  49 #if !defined EMOD_CL_MONOMOD
  50 #define INIT    cl_LTX_init
  51 #define REINIT  cl_LTX_reinit
  52 #define DEINIT  cl_LTX_deinit
  53 #else
  54 #define INIT    cl_mono_LTX_init
  55 #define REINIT  cl_mono_LTX_reinit
  56 #define DEINIT  cl_mono_LTX_deinit
  57 #endif
  58
  59 \f
  60 /* ###autoload */
  61 DEFUN("cl:pop", Fcl_pop, 1, UNEVALLED, 0, /*
  62 (pop PLACE): remove and return the head of the list stored in PLACE.
  63 Analogous to (prog1 (car PLACE) (setf PLACE (cdr PLACE))), though more
  64 careful about evaluating each argument only once and in the right order.
  65 PLACE may be a symbol, or any generalized variable allowed by `setf'.
  66                                           */
  67       (args))
  68 {
  69         /* This function can GC */
  70         Lisp_Object place = XCAR(args);
  71         Lisp_Object result = Qnil;
  72         struct gcpro gcpro1, gcpro2;
  73
  74         GCPRO2(result, place);
  75
  76         if (SYMBOLP(place)) {
  77                 Lisp_Object ls;
  78                 ls = Fsymbol_value(place);
  79                 if (CONSP(ls)) {
  80                         result = XCAR(ls);
  81                         Fset(place, XCDR(ls));
  82                 }
  83         }
  84
  85         UNGCPRO;
  86         return result;
  87 }
  88
  89 /* ###autoload */
  90 DEFUN("cl:push", Fcl_push, 2, UNEVALLED, 0, /*
  91 (push X PLACE): insert X at the head of the list stored in PLACE.
  92 Analogous to (setf PLACE (cons X PLACE)), though more careful about
  93 evaluating each argument only once and in the right order.  PLACE may
  94 be a symbol, or any generalized variable allowed by `setf'; that is,
  95 it does not necessarily have to be a list, though `push' is most often
  96 used on lists.
  97                                             */
  98       (args))
  99 {
 100         /* This function can GC */
 101         Lisp_Object x = XCAR(args);
 102         Lisp_Object place = XCAR(XCDR(args));
 103         Lisp_Object result = Qnil;
 104         struct gcpro gcpro1, gcpro2, gcpro3;
 105
 106         GCPRO3(result, x, place);
 107
 108         if (SYMBOLP(place)) {
 109                 Lisp_Object ls;
 110                 ls = Fsymbol_value(place);
 111                 x = Feval(x);
 112                 Fset(place, (result = Fcons(x, ls)));
 113         }
 114
 115         UNGCPRO;
 116         return result;
 117 }
 118
 119 /* ###autoload */
 120 DEFUN("cl:pushnew", Fcl_pushnew, 2, UNEVALLED, 0, /*
 121 (pushnew X PLACE): insert X at the head of the list stored in PLACE.
 122 Like (push X PLACE), except that the list is unmodified if X is `eql'
 123 to an element already on the list.
 124 Keywords supported: :test :test-not :key
 125                                                   */
 126       (args))
 127 {
 128         /* This function can GC */
 129         Lisp_Object x = XCAR(args);
 130         Lisp_Object place = XCAR(XCDR(args));
 131         Lisp_Object result = Qnil;
 132         struct gcpro gcpro1, gcpro2, gcpro3;
 133
 134         GCPRO3(result, x, place);
 135
 136         if (SYMBOLP(place)) {
 137                 Lisp_Object ls;
 138                 result = ls = Fsymbol_value(place);
 139                 if (0) {        /* !X_NOT_FOUND_IN_LS_P */
 140                         x = Feval(x);
 141                         Fset(place, (result = Fcons(x, ls)));
 142                 }
 143         }
 144
 145         UNGCPRO;
 146         return result;
 147 }
 148
 149 #define EMOD_CL_EQL(_a, _b)                                             \
 150         ((!FLOATP(_a)) ? (EQ((_a), (_b))) : (!NILP(Fequal((_a), (_b)))))
 151 static inline
 152 int emodcl_eql(Lisp_Object a, Lisp_Object b)
 153 {
 154         return EMOD_CL_EQL(a, b);
 155 }
 156
 157 /* ###autoload */
 158 DEFUN("cl:eql", Fcl_eql, 2, 2, 0, /*
 159 Return t if the two args are the same Lisp object.
 160 Floating-point numbers of equal value are `eql', but they may not be `eq'.
 161                                   */
 162       (a, b))
 163 {
 164         if (EMOD_CL_EQL(a, b))
 165                 return Qt;
 166         else
 167                 return Qnil;
 168 }
 169
 170 /* ###autoload */
 171 DEFUN("cl:list*", Fcl_list_, 1, MANY, 0, /*
 172 Return a new list with specified args as elements, cons'd to last arg.
 173 Thus, `(list* A B C D)' is equivalent to `(nconc (list A B C) D)', or to
 174 `(cons A (cons B (cons C D)))'.
 175                                          */
 176       (int nargs, Lisp_Object *args))
 177 {
 178         if (nargs == 1)
 179                 return args[0];
 180         else {
 181                 Lisp_Object result = args[--nargs];
 182                 for (; nargs > 0; ) {
 183                         result = Fcons(args[--nargs], result);
 184                 }
 185                 return result;
 186         }
 187 }
 188
 189 /* ###autoload */
 190 DEFUN("cl:tailp", Fcl_tailp, 2, 2, 0, /*
 191 Return true if SUBLIST is a tail of LIST.
 192                                       */
 193       (list, object))
 194 {
 195         Lisp_Object trav1 = Qnil, trav2 = Qnil;
 196
 197         CHECK_CONS(list);
 198
 199         if (CONSP(object)) {
 200                 trav2 = XCAR(object);
 201                 for (trav1 = list; CONSP(trav1); trav1 = XCDR(trav1)) {
 202                         if (EMOD_CL_EQL(XCAR(trav1), trav2))
 203                                 break;
 204                 }
 205                 if (!CONSP(trav1))
 206                         return Qnil;
 207
 208                 for (trav1 = XCDR(trav1), trav2 = XCDR(object);
 209                      CONSP(trav1) && CONSP(trav2);
 210                      trav1 = XCDR(trav1), trav2 = XCDR(trav2)) {
 211                         if (!EMOD_CL_EQL(XCAR(trav1), XCAR(trav2))) {
 212                                 return Qnil;
 213                         }
 214                 }
 215                 if (EMOD_CL_EQL(trav1, trav2))
 216                         return Qt;
 217                 else
 218                         return Qnil;
 219
 220         } else {
 221                 for (trav1 = list; CONSP(trav1); trav1 = XCDR(trav1));
 222                 if (EMOD_CL_EQL(trav1, object))
 223                         return Qt;
 224                 else
 225                         return Qnil;
 226         }
 227         return Qnil;
 228 }
 229
 230 /* ###autoload */
 231 DEFUN("cl:ldiff", Fcl_ldiff, 2, 2, 0, /*
 232 Return a copy of LIST with the tail SUBLIST removed.
 233                                       */
 234       (list, object))
 235 {
 236         Lisp_Object result = Qnil, tmp1 = Qnil, tmp2 = Qnil;
 237         Lisp_Object trav1 = Qnil, trav2 = Qnil;
 238         int yes;
 239
 240         CHECK_CONS(list);
 241
 242         if (CONSP(object)) {
 243                 trav2 = XCAR(object);
 244                 for (trav1 = list; CONSP(trav1); trav1 = XCDR(trav1)) {
 245                         if (EMOD_CL_EQL(XCAR(trav1), trav2))
 246                                 break;
 247                         tmp1 = Fcons(XCAR(trav1), tmp1);
 248                 }
 249                 /* we traversed list and haven't found a match yet */
 250                 if (!CONSP(trav1)) {
 251                         result = trav1;
 252                         goto build_result;
 253                 } else {
 254                         tmp2 = trav1;
 255                 }
 256
 257                 yes = 1;
 258                 for (trav1 = XCDR(trav1), trav2 = XCDR(object);
 259                      CONSP(trav1) && CONSP(trav2);
 260                      trav1 = XCDR(trav1), trav2 = XCDR(trav2)) {
 261                         if (yes && !EMOD_CL_EQL(XCAR(trav1), XCAR(trav2))) {
 262                                 yes = 0;
 263                         }
 264                 }
 265                 if (!yes || !EMOD_CL_EQL(trav1, trav2)) {
 266                         /* if not, just pump the rest */
 267                         for (trav1 = tmp2; CONSP(trav1); trav1 = XCDR(trav1)) {
 268                                 tmp1 = Fcons(XCAR(trav1), tmp1);
 269                         }
 270                         result = trav1;
 271                 }
 272         } else {
 273                 for (trav1 = list; CONSP(trav1); trav1 = XCDR(trav1))
 274                         tmp1 = Fcons(XCAR(trav1), tmp1);
 275                 if (!EMOD_CL_EQL(trav1, object))
 276                         result = trav1;
 277         }
 278
 279 build_result:
 280         /* push the head */
 281         for (trav1 = tmp1; CONSP(trav1); trav1 = XCDR(trav1)) {
 282                 result = Fcons(XCAR(trav1), result);
 283         }
 284
 285         return result;
 286 }
 287
 288 #if 0
 289 /* ###4utoload */
 290 D3FUN("cl:adjoin", Fcl_adjoin, 2, MANY, 0, /*
 291                                            */
 292       (int nargs, Lisp_Object *args))
 293 {
 294         return Qnil;
 295 }
 296 #endif  /* 0 */
 297
 298 \f
 299 /* simplified initialiser */
 300 void
 301 INIT(void)
 302 {
 303         DEFSUBR(Fcl_pop);
 304         DEFSUBR(Fcl_push);
 305         DEFSUBR(Fcl_pushnew);
 306
 307         DEFSUBR(Fcl_list_);
 308         DEFSUBR(Fcl_tailp);
 309         DEFSUBR(Fcl_ldiff);
 310
 311         DEFSUBR(Fcl_eql);
 312
 313 #if defined EMOD_CL_MONOMOD
 314         cl_loop_LTX_init();
 315 #endif
 316
 317         Fprovide(intern("cl"));
 318 }
 319
 320 void
 321 DEINIT(void)
 322 {
 323 }
 324
 325 void
 326 REINIT(void)
 327 {
 328         Frevoke(intern("cl"));
 329 }
 330
 331 /* cl.c ends here */