1 /*
2 * Copyright (c) 2001 by The XFree86 Project, Inc.
3 *
4 * Permission is hereby granted, free of charge, to any person obtaining a
5 * copy of this software and associated documentation files (the "Software"),
6 * to deal in the Software without restriction, including without limitation
7 * the rights to use, copy, modify, merge, publish, distribute, sublicense,
8 * and/or sell copies of the Software, and to permit persons to whom the
9 * Software is furnished to do so, subject to the following conditions:
10 *
11 * The above copyright notice and this permission notice shall be included in
12 * all copies or substantial portions of the Software.
13 *
14 * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
15 * IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
16 * FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
17 * THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
18 * WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF
19 * OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
20 * SOFTWARE.
21 *
22 * Except as contained in this notice, the name of the XFree86 Project shall
23 * not be used in advertising or otherwise to promote the sale, use or other
24 * dealings in this Software without prior written authorization from the
25 * XFree86 Project.
26 *
27 * Author: Paulo César Pereira de Andrade
28 */
29
30 /* $XFree86: xc/programs/xedit/lisp/core.c,v 1.71tsi Exp $ */
31
32 #include "lisp/io.h"
33 #include "lisp/core.h"
34 #include "lisp/format.h"
35 #include "lisp/helper.h"
36 #include "lisp/package.h"
37 #include "lisp/private.h"
38 #include "lisp/write.h"
39
40 /*
41 * Types
42 */
43 typedef struct _SeqInfo {
44 LispType type;
45 union {
46 LispObj *list;
47 LispObj **vector;
48 unsigned char *string;
49 } data;
50 } SeqInfo;
51
52 #define SETSEQ(seq, object) \
53 switch (seq.type = XOBJECT_TYPE(object)) { \
54 case LispString_t: \
55 seq.data.string = (unsigned char*)THESTR(object); \
56 break; \
57 case LispCons_t: \
58 seq.data.list = object; \
59 break; \
60 default: \
61 seq.data.list = object->data.array.list; \
62 break; \
63 }
64
65 #ifdef __UNIXOS2__
66 # define finite(x) isfinite(x)
67 #endif
68
69 #ifdef NEED_SETENV
70 extern int setenv(const char *name, const char *value, int overwrite);
71 extern void unsetenv(const char *name);
72 #endif
73
74 /*
75 * Prototypes
76 */
77 #define NONE 0
78
79 #define REMOVE 1
80 #define SUBSTITUTE 2
81 #define DELETE 3
82 #define NSUBSTITUTE 4
83
84 #define ASSOC 1
85 #define MEMBER 2
86
87 #define FIND 1
88 #define POSITION 2
89
90 #define IF 1
91 #define IFNOT 2
92
93 #define UNION 1
94 #define INTERSECTION 2
95 #define SETDIFFERENCE 3
96 #define SETEXCLUSIVEOR 4
97 #define SUBSETP 5
98 #define NSETDIFFERENCE 6
99 #define NINTERSECTION 7
100 #define NUNION 8
101 #define NSETEXCLUSIVEOR 9
102
103 #define COPY_LIST 1
104 #define COPY_ALIST 2
105 #define COPY_TREE 3
106
107 #define EVERY 1
108 #define SOME 2
109 #define NOTEVERY 3
110 #define NOTANY 4
111
112 /* Call directly LispObjectCompare() if possible */
113 #define FCODE(predicate) \
114 predicate == Oeql ? FEQL : \
115 predicate == Oequal ? FEQUAL : \
116 predicate == Oeq ? FEQ : \
117 predicate == Oequalp ? FEQUALP : 0
118 #define FCOMPARE(predicate, left, right, code) \
119 code == FEQ ? left == right : \
120 code ? LispObjectCompare(left, right, code) != NIL : \
121 APPLY2(predicate, left, right) != NIL
122
123 #define FUNCTION_CHECK(predicate) \
124 if (FUNCTIONP(predicate)) \
125 predicate = (predicate)->data.atom->object
126
127 #define CHECK_TEST_0() \
128 if (test != UNSPEC && test_not != UNSPEC) \
129 LispDestroy("%s: specify either :TEST or :TEST-NOT", \
130 STRFUN(builtin))
131
132 #define CHECK_TEST() \
133 CHECK_TEST_0(); \
134 if (test_not == UNSPEC) { \
135 if (test == UNSPEC) \
136 lambda = Oeql; \
137 else \
138 lambda = test; \
139 expect = 1; \
140 } \
141 else { \
142 lambda = test_not; \
143 expect = 0; \
144 } \
145 FUNCTION_CHECK(lambda); \
146 code = FCODE(lambda)
147
148
149 static LispObj *LispAdjoin(LispBuiltin*,
150 LispObj*, LispObj*, LispObj*, LispObj*, LispObj*);
151 static LispObj *LispAssocOrMember(LispBuiltin*, int, int);
152 static LispObj *LispEverySomeAnyNot(LispBuiltin*, int);
153 static LispObj *LispFindOrPosition(LispBuiltin*, int, int);
154 static LispObj *LispDeleteOrRemoveDuplicates(LispBuiltin*, int);
155 static LispObj *LispDeleteRemoveXSubstitute(LispBuiltin*, int, int);
156 static LispObj *LispListSet(LispBuiltin*, int);
157 static LispObj *LispMapc(LispBuiltin*, int);
158 static LispObj *LispMapl(LispBuiltin*, int);
159 static LispObj *LispMapnconc(LispObj*);
160 extern LispObj *LispRunSetf(LispArgList*, LispObj*, LispObj*, LispObj*);
161 extern LispObj *LispRunSetfMacro(LispAtom*, LispObj*, LispObj*);
162 static LispObj *LispMergeSort(LispObj*, LispObj*, LispObj*, int);
163 static LispObj *LispXReverse(LispBuiltin*, int);
164 static LispObj *LispCopyList(LispBuiltin*, LispObj*, int);
165 static LispObj *LispValuesList(LispBuiltin*, int);
166 static LispObj *LispTreeEqual(LispObj*, LispObj*, LispObj*, int);
167 static LispDocType_t LispDocumentationType(LispBuiltin*, LispObj*);
168
169 extern void LispSetAtomObjectProperty(LispAtom*, LispObj*);
170
171 /*
172 * Initialization
173 */
174 LispObj *Oeq, *Oeql, *Oequal, *Oequalp, *Omake_array,
175 *Kinitial_contents, *Osetf, *Ootherwise, *Oquote;
176 LispObj *Ogensym_counter;
177
178 Atom_id Svariable, Sstructure, Stype, Ssetf;
179
180 /*
181 * Implementation
182 */
183 void
LispCoreInit(void)184 LispCoreInit(void)
185 {
186 Oeq = STATIC_ATOM("EQ");
187 Oeql = STATIC_ATOM("EQL");
188 Oequal = STATIC_ATOM("EQUAL");
189 Oequalp = STATIC_ATOM("EQUALP");
190 Omake_array = STATIC_ATOM("MAKE-ARRAY");
191 Kinitial_contents = KEYWORD("INITIAL-CONTENTS");
192 Osetf = STATIC_ATOM("SETF");
193 Ootherwise = STATIC_ATOM("OTHERWISE");
194 LispExportSymbol(Ootherwise);
195 Oquote = STATIC_ATOM("QUOTE");
196 LispExportSymbol(Oquote);
197
198 Svariable = GETATOMID("VARIABLE");
199 Sstructure = GETATOMID("STRUCTURE");
200 Stype = GETATOMID("TYPE");
201
202 /* Create as a constant so that only the C code should change the value */
203 Ogensym_counter = STATIC_ATOM("*GENSYM-COUNTER*");
204 LispDefconstant(Ogensym_counter, FIXNUM(0), NIL);
205 LispExportSymbol(Ogensym_counter);
206
207 Ssetf = ATOMID(Osetf);
208 }
209
210 LispObj *
Lisp_Acons(LispBuiltin * builtin)211 Lisp_Acons(LispBuiltin *builtin)
212 /*
213 acons key datum alist
214 */
215 {
216 LispObj *key, *datum, *alist;
217
218 alist = ARGUMENT(2);
219 datum = ARGUMENT(1);
220 key = ARGUMENT(0);
221
222 return (CONS(CONS(key, datum), alist));
223 }
224
225 static LispObj *
LispAdjoin(LispBuiltin * builtin,LispObj * item,LispObj * list,LispObj * key,LispObj * test,LispObj * test_not)226 LispAdjoin(LispBuiltin*builtin, LispObj *item, LispObj *list,
227 LispObj *key, LispObj *test, LispObj *test_not)
228 {
229 GC_ENTER();
230 int code, expect, value;
231 LispObj *lambda, *compare, *object;
232
233 CHECK_LIST(list);
234 CHECK_TEST();
235
236 if (key != UNSPEC) {
237 item = APPLY1(key, item);
238 /* Result is not guaranteed to be gc protected */
239 GC_PROTECT(item);
240 }
241
242 /* Check if item is not already in place */
243 for (object = list; CONSP(object); object = CDR(object)) {
244 compare = CAR(object);
245 if (key != UNSPEC) {
246 compare = APPLY1(key, compare);
247 GC_PROTECT(compare);
248 value = FCOMPARE(lambda, item, compare, code);
249 /* Unprotect compare... */
250 --lisp__data.protect.length;
251 }
252 else
253 value = FCOMPARE(lambda, item, compare, code);
254
255 if (value == expect) {
256 /* Item is already in list */
257 GC_LEAVE();
258
259 return (list);
260 }
261 }
262 GC_LEAVE();
263
264 return (CONS(item, list));
265 }
266
267 LispObj *
Lisp_Adjoin(LispBuiltin * builtin)268 Lisp_Adjoin(LispBuiltin *builtin)
269 /*
270 adjoin item list &key key test test-not
271 */
272 {
273 LispObj *item, *list, *key, *test, *test_not;
274
275 test_not = ARGUMENT(4);
276 test = ARGUMENT(3);
277 key = ARGUMENT(2);
278 list = ARGUMENT(1);
279 item = ARGUMENT(0);
280
281 return (LispAdjoin(builtin, item, list, key, test, test_not));
282 }
283
284 LispObj *
Lisp_Append(LispBuiltin * builtin)285 Lisp_Append(LispBuiltin *builtin)
286 /*
287 append &rest lists
288 */
289 {
290 GC_ENTER();
291 LispObj *result, *cons, *list;
292
293 LispObj *lists;
294
295 lists = ARGUMENT(0);
296
297 /* no arguments */
298 if (!CONSP(lists))
299 return (NIL);
300
301 /* skip initial nil lists */
302 for (; CONSP(CDR(lists)) && CAR(lists) == NIL; lists = CDR(lists))
303 ;
304
305 /* last argument is not copied (even if it is the single argument) */
306 if (!CONSP(CDR(lists)))
307 return (CAR(lists));
308
309 /* make sure result is a list */
310 list = CAR(lists);
311 CHECK_CONS(list);
312 result = cons = CONS(CAR(list), NIL);
313 GC_PROTECT(result);
314 for (list = CDR(list); CONSP(list); list = CDR(list)) {
315 RPLACD(cons, CONS(CAR(list), NIL));
316 cons = CDR(cons);
317 }
318 lists = CDR(lists);
319
320 /* copy intermediate lists */
321 for (; CONSP(CDR(lists)); lists = CDR(lists)) {
322 list = CAR(lists);
323 if (list == NIL)
324 continue;
325 /* intermediate elements must be lists */
326 CHECK_CONS(list);
327 for (; CONSP(list); list = CDR(list)) {
328 RPLACD(cons, CONS(CAR(list), NIL));
329 cons = CDR(cons);
330 }
331 }
332
333 /* add last element */
334 RPLACD(cons, CAR(lists));
335
336 GC_LEAVE();
337
338 return (result);
339 }
340
341 LispObj *
Lisp_Aref(LispBuiltin * builtin)342 Lisp_Aref(LispBuiltin *builtin)
343 /*
344 aref array &rest subscripts
345 */
346 {
347 long c, count, idx, seq;
348 LispObj *obj, *dim;
349
350 LispObj *array, *subscripts;
351
352 subscripts = ARGUMENT(1);
353 array = ARGUMENT(0);
354
355 /* accept strings also */
356 if (STRINGP(array) && CONSP(subscripts) && CDR(subscripts) == NIL) {
357 long offset, length = STRLEN(array);
358
359 CHECK_INDEX(CAR(subscripts));
360 offset = FIXNUM_VALUE(CAR(subscripts));
361
362 if (offset >= length)
363 LispDestroy("%s: index %ld too large for sequence length %ld",
364 STRFUN(builtin), offset, length);
365
366 return (SCHAR(THESTR(array)[offset]));
367 }
368
369 CHECK_ARRAY(array);
370
371 for (count = 0, dim = subscripts, obj = array->data.array.dim; CONSP(dim);
372 count++, dim = CDR(dim), obj = CDR(obj)) {
373 if (count >= array->data.array.rank)
374 LispDestroy("%s: too many subscripts %s",
375 STRFUN(builtin), STROBJ(subscripts));
376 if (!INDEXP(CAR(dim)) ||
377 FIXNUM_VALUE(CAR(dim)) >= FIXNUM_VALUE(CAR(obj)))
378 LispDestroy("%s: %s is out of range or a bad index",
379 STRFUN(builtin), STROBJ(CAR(dim)));
380 }
381 if (count < array->data.array.rank)
382 LispDestroy("%s: too few subscripts %s",
383 STRFUN(builtin), STROBJ(subscripts));
384
385 for (count = seq = 0, dim = subscripts; CONSP(dim); dim = CDR(dim), seq++) {
386 for (idx = 0, obj = array->data.array.dim; idx < seq;
387 obj = CDR(obj), ++idx)
388 ;
389 for (c = 1, obj = CDR(obj); obj != NIL; obj = CDR(obj))
390 c *= FIXNUM_VALUE(CAR(obj));
391 count += c * FIXNUM_VALUE(CAR(dim));
392 }
393
394 for (array = array->data.array.list; count > 0; array = CDR(array), count--)
395 ;
396
397 return (CAR(array));
398 }
399
400 static LispObj *
LispAssocOrMember(LispBuiltin * builtin,int function,int comparison)401 LispAssocOrMember(LispBuiltin *builtin, int function, int comparison)
402 /*
403 assoc item list &key test test-not key
404 assoc-if predicate list &key key
405 assoc-if-not predicate list &key key
406 member item list &key test test-not key
407 member-if predicate list &key key
408 member-if-not predicate list &key key
409 */
410 {
411 int code = 0, expect, value;
412 LispObj *lambda, *result, *compare;
413
414 LispObj *item, *list, *test, *test_not, *key;
415
416 if (comparison == NONE) {
417 key = ARGUMENT(4);
418 test_not = ARGUMENT(3);
419 test = ARGUMENT(2);
420 list = ARGUMENT(1);
421 item = ARGUMENT(0);
422 lambda = NIL;
423 }
424 else {
425 key = ARGUMENT(2);
426 list = ARGUMENT(1);
427 lambda = ARGUMENT(0);
428 test = test_not = UNSPEC;
429 item = NIL;
430 }
431
432 if (list == NIL)
433 return (NIL);
434 CHECK_CONS(list);
435
436 /* Resolve compare function, and expected result of comparison */
437 if (comparison == NONE) {
438 CHECK_TEST();
439 }
440 else
441 expect = comparison == IFNOT ? 0 : 1;
442
443 result = NIL;
444 for (; CONSP(list); list = CDR(list)) {
445 compare = CAR(list);
446 if (function == ASSOC) {
447 if (!CONSP(compare))
448 continue;
449 compare = CAR(compare);
450 }
451 if (key != UNSPEC)
452 compare = APPLY1(key, compare);
453
454 if (comparison == NONE)
455 value = FCOMPARE(lambda, item, compare, code);
456 else
457 value = APPLY1(lambda, compare) != NIL;
458 if (value == expect) {
459 result = list;
460 if (function == ASSOC)
461 result = CAR(result);
462 break;
463 }
464 }
465 if (function == MEMBER) {
466 CHECK_LIST(list);
467 }
468
469 return (result);
470 }
471
472 LispObj *
Lisp_Assoc(LispBuiltin * builtin)473 Lisp_Assoc(LispBuiltin *builtin)
474 /*
475 assoc item list &key test test-not key
476 */
477 {
478 return (LispAssocOrMember(builtin, ASSOC, NONE));
479 }
480
481 LispObj *
Lisp_AssocIf(LispBuiltin * builtin)482 Lisp_AssocIf(LispBuiltin *builtin)
483 /*
484 assoc-if predicate list &key key
485 */
486 {
487 return (LispAssocOrMember(builtin, ASSOC, IF));
488 }
489
490 LispObj *
Lisp_AssocIfNot(LispBuiltin * builtin)491 Lisp_AssocIfNot(LispBuiltin *builtin)
492 /*
493 assoc-if-not predicate list &key key
494 */
495 {
496 return (LispAssocOrMember(builtin, ASSOC, IFNOT));
497 }
498
499 LispObj *
Lisp_And(LispBuiltin * builtin)500 Lisp_And(LispBuiltin *builtin)
501 /*
502 and &rest args
503 */
504 {
505 LispObj *result = T, *args;
506
507 args = ARGUMENT(0);
508
509 for (; CONSP(args); args = CDR(args)) {
510 result = EVAL(CAR(args));
511 if (result == NIL)
512 break;
513 }
514
515 return (result);
516 }
517
518 LispObj *
Lisp_Apply(LispBuiltin * builtin)519 Lisp_Apply(LispBuiltin *builtin)
520 /*
521 apply function arg &rest more-args
522 */
523 {
524 GC_ENTER();
525 LispObj *result, *arguments;
526
527 LispObj *function, *arg, *more_args;
528
529 more_args = ARGUMENT(2);
530 arg = ARGUMENT(1);
531 function = ARGUMENT(0);
532
533 if (more_args == NIL) {
534 CHECK_LIST(arg);
535 arguments = arg;
536 for (; CONSP(arg); arg = CDR(arg))
537 ;
538 CHECK_LIST(arg);
539 }
540 else {
541 LispObj *cons;
542
543 CHECK_CONS(more_args);
544 arguments = cons = CONS(arg, NIL);
545 GC_PROTECT(arguments);
546 for (arg = CDR(more_args);
547 CONSP(arg);
548 more_args = arg, arg = CDR(arg)) {
549 RPLACD(cons, CONS(CAR(more_args), NIL));
550 cons = CDR(cons);
551 }
552 more_args = CAR(more_args);
553 if (more_args != NIL) {
554 for (arg = more_args; CONSP(arg); arg = CDR(arg))
555 ;
556 CHECK_LIST(arg);
557 RPLACD(cons, more_args);
558 }
559 }
560
561 result = APPLY(function, arguments);
562 GC_LEAVE();
563
564 return (result);
565 }
566
567 LispObj *
Lisp_Atom(LispBuiltin * builtin)568 Lisp_Atom(LispBuiltin *builtin)
569 /*
570 atom object
571 */
572 {
573 LispObj *object;
574
575 object = ARGUMENT(0);
576
577 return (CONSP(object) ? NIL : T);
578 }
579
580 LispObj *
Lisp_Block(LispBuiltin * builtin)581 Lisp_Block(LispBuiltin *builtin)
582 /*
583 block name &rest body
584 */
585 {
586 int did_jump, *pdid_jump = &did_jump;
587 LispObj *res, **pres = &res;
588 LispBlock *block;
589
590 LispObj *name, *body;
591
592 body = ARGUMENT(1);
593 name = ARGUMENT(0);
594
595 if (!SYMBOLP(name) && name != NIL && name != T)
596 LispDestroy("%s: %s cannot name a block",
597 STRFUN(builtin), STROBJ(name));
598
599 *pres = NIL;
600 *pdid_jump = 1;
601 block = LispBeginBlock(name, LispBlockTag);
602 if (setjmp(block->jmp) == 0) {
603 for (; CONSP(body); body = CDR(body))
604 res = EVAL(CAR(body));
605 *pdid_jump = 0;
606 }
607 LispEndBlock(block);
608 if (*pdid_jump)
609 *pres = lisp__data.block.block_ret;
610
611 return (res);
612 }
613
614 LispObj *
Lisp_Boundp(LispBuiltin * builtin)615 Lisp_Boundp(LispBuiltin *builtin)
616 /*
617 boundp symbol
618 */
619 {
620 LispAtom *atom;
621
622 LispObj *symbol = ARGUMENT(0);
623
624 CHECK_SYMBOL(symbol);
625
626 atom = symbol->data.atom;
627 if (atom->package == lisp__data.keyword ||
628 (atom->a_object && atom->property->value != UNBOUND))
629 return (T);
630
631 return (NIL);
632 }
633
634 LispObj *
Lisp_Butlast(LispBuiltin * builtin)635 Lisp_Butlast(LispBuiltin *builtin)
636 /*
637 butlast list &optional count
638 */
639 {
640 GC_ENTER();
641 long length, count;
642 LispObj *result, *cons, *list, *ocount;
643
644 ocount = ARGUMENT(1);
645 list = ARGUMENT(0);
646
647 CHECK_LIST(list);
648 if (ocount == UNSPEC)
649 count = 1;
650 else {
651 CHECK_INDEX(ocount);
652 count = FIXNUM_VALUE(ocount);
653 }
654 length = LispLength(list);
655
656 if (count == 0)
657 return (list);
658 else if (count >= length)
659 return (NIL);
660
661 length -= count + 1;
662 result = cons = CONS(CAR(list), NIL);
663 GC_PROTECT(result);
664 for (list = CDR(list); length > 0; list = CDR(list), length--) {
665 RPLACD(cons, CONS(CAR(list), NIL));
666 cons = CDR(cons);
667 }
668 GC_LEAVE();
669
670 return (result);
671 }
672
673 LispObj *
Lisp_Nbutlast(LispBuiltin * builtin)674 Lisp_Nbutlast(LispBuiltin *builtin)
675 /*
676 nbutlast list &optional count
677 */
678 {
679 long length, count;
680 LispObj *result, *list, *ocount;
681
682 ocount = ARGUMENT(1);
683 list = ARGUMENT(0);
684
685 CHECK_LIST(list);
686 if (ocount == UNSPEC)
687 count = 1;
688 else {
689 CHECK_INDEX(ocount);
690 count = FIXNUM_VALUE(ocount);
691 }
692 length = LispLength(list);
693
694 if (count == 0)
695 return (list);
696 else if (count >= length)
697 return (NIL);
698
699 length -= count + 1;
700 result = list;
701 for (; length > 0; list = CDR(list), length--)
702 ;
703 RPLACD(list, NIL);
704
705 return (result);
706 }
707
708 LispObj *
Lisp_Car(LispBuiltin * builtin)709 Lisp_Car(LispBuiltin *builtin)
710 /*
711 car list
712 */
713 {
714 LispObj *list, *result = NULL;
715
716 list = ARGUMENT(0);
717
718 if (list == NIL)
719 result = NIL;
720 else {
721 CHECK_CONS(list);
722 result = CAR(list);
723 }
724
725 return (result);
726 }
727
728 LispObj *
Lisp_Case(LispBuiltin * builtin)729 Lisp_Case(LispBuiltin *builtin)
730 /*
731 case keyform &rest body
732 */
733 {
734 LispObj *result, *code, *keyform, *body, *form;
735
736 body = ARGUMENT(1);
737 keyform = ARGUMENT(0);
738
739 result = NIL;
740 keyform = EVAL(keyform);
741
742 for (; CONSP(body); body = CDR(body)) {
743 code = CAR(body);
744 CHECK_CONS(code);
745
746 form = CAR(code);
747 if (form == T || form == Ootherwise) {
748 if (CONSP(CDR(body)))
749 LispDestroy("%s: %s must be the last clause",
750 STRFUN(builtin), STROBJ(CAR(code)));
751 result = CDR(code);
752 break;
753 }
754 else if (CONSP(form)) {
755 for (; CONSP(form); form = CDR(form))
756 if (XEQL(keyform, CAR(form)) == T) {
757 result = CDR(code);
758 break;
759 }
760 if (CONSP(form)) /* if found match */
761 break;
762 }
763 else if (XEQL(keyform, form) == T) {
764 result = CDR(code);
765 break;
766 }
767 }
768
769 for (body = result; CONSP(body); body = CDR(body))
770 result = EVAL(CAR(body));
771
772 return (result);
773 }
774
775 LispObj *
Lisp_Catch(LispBuiltin * builtin)776 Lisp_Catch(LispBuiltin *builtin)
777 /*
778 catch tag &rest body
779 */
780 {
781 int did_jump, *pdid_jump = &did_jump;
782 LispObj *res, **pres = &res;
783 LispBlock *block;
784
785 LispObj *tag, *body;
786
787 body = ARGUMENT(1);
788 tag = ARGUMENT(0);
789
790 *pres = NIL;
791 *pdid_jump = 1;
792 block = LispBeginBlock(tag, LispBlockCatch);
793 if (setjmp(block->jmp) == 0) {
794 for (; CONSP(body); body = CDR(body))
795 res = EVAL(CAR(body));
796 *pdid_jump = 0;
797 }
798 LispEndBlock(block);
799 if (*pdid_jump)
800 *pres = lisp__data.block.block_ret;
801
802 return (res);
803 }
804
805 LispObj *
Lisp_Coerce(LispBuiltin * builtin)806 Lisp_Coerce(LispBuiltin *builtin)
807 /*
808 coerce object result-type
809 */
810 {
811 LispObj *object, *result_type;
812
813 result_type = ARGUMENT(1);
814 object = ARGUMENT(0);
815
816 return (LispCoerce(builtin, object, result_type));
817 }
818
819 LispObj *
Lisp_Cdr(LispBuiltin * builtin)820 Lisp_Cdr(LispBuiltin *builtin)
821 /*
822 cdr list
823 */
824 {
825 LispObj *list, *result = NULL;
826
827 list = ARGUMENT(0);
828
829 if (list == NIL)
830 result = NIL;
831 else {
832 CHECK_CONS(list);
833 result = CDR(list);
834 }
835
836 return (result);
837 }
838
839 LispObj *
Lisp_C_r(LispBuiltin * builtin)840 Lisp_C_r(LispBuiltin *builtin)
841 /*
842 c[ad]{2,4}r list
843 */
844 {
845 char *desc;
846
847 LispObj *list, *result = NULL;
848
849 list = ARGUMENT(0);
850
851 result = list;
852 desc = STRFUN(builtin);
853 while (desc[1] != 'R')
854 ++desc;
855 while (*desc != 'C') {
856 if (result == NIL)
857 break;
858 CHECK_CONS(result);
859 result = *desc == 'A' ? CAR(result) : CDR(result);
860 --desc;
861 }
862
863 return (result);
864 }
865
866 LispObj *
Lisp_Cond(LispBuiltin * builtin)867 Lisp_Cond(LispBuiltin *builtin)
868 /*
869 cond &rest body
870 */
871 {
872 LispObj *result, *code, *body;
873
874 body = ARGUMENT(0);
875
876 result = NIL;
877 for (; CONSP(body); body = CDR(body)) {
878 code = CAR(body);
879
880 CHECK_CONS(code);
881 result = EVAL(CAR(code));
882 if (result == NIL)
883 continue;
884 for (code = CDR(code); CONSP(code); code = CDR(code))
885 result = EVAL(CAR(code));
886 break;
887 }
888
889 return (result);
890 }
891
892 static LispObj *
LispCopyList(LispBuiltin * builtin,LispObj * list,int function)893 LispCopyList(LispBuiltin *builtin, LispObj *list, int function)
894 {
895 GC_ENTER();
896 LispObj *result, *cons;
897
898 if (list == NIL)
899 return (list);
900 CHECK_CONS(list);
901
902 result = cons = CONS(NIL, NIL);
903 GC_PROTECT(result);
904 if (CONSP(CAR(list))) {
905 switch (function) {
906 case COPY_LIST:
907 RPLACA(result, CAR(list));
908 break;
909 case COPY_ALIST:
910 RPLACA(result, CONS(CAR(CAR(list)), CDR(CAR(list))));
911 break;
912 case COPY_TREE:
913 RPLACA(result, LispCopyList(builtin, CAR(list), COPY_TREE));
914 break;
915 }
916 }
917 else
918 RPLACA(result, CAR(list));
919
920 for (list = CDR(list); CONSP(list); list = CDR(list)) {
921 CDR(cons) = CONS(NIL, NIL);
922 cons = CDR(cons);
923 if (CONSP(CAR(list))) {
924 switch (function) {
925 case COPY_LIST:
926 RPLACA(cons, CAR(list));
927 break;
928 case COPY_ALIST:
929 RPLACA(cons, CONS(CAR(CAR(list)), CDR(CAR(list))));
930 break;
931 case COPY_TREE:
932 RPLACA(cons, LispCopyList(builtin, CAR(list), COPY_TREE));
933 break;
934 }
935 }
936 else
937 RPLACA(cons, CAR(list));
938 }
939 /* in case list is dotted */
940 RPLACD(cons, list);
941 GC_LEAVE();
942
943 return (result);
944 }
945
946 LispObj *
Lisp_CopyAlist(LispBuiltin * builtin)947 Lisp_CopyAlist(LispBuiltin *builtin)
948 /*
949 copy-alist list
950 */
951 {
952 LispObj *list;
953
954 list = ARGUMENT(0);
955
956 return (LispCopyList(builtin, list, COPY_ALIST));
957 }
958
959 LispObj *
Lisp_CopyList(LispBuiltin * builtin)960 Lisp_CopyList(LispBuiltin *builtin)
961 /*
962 copy-list list
963 */
964 {
965 LispObj *list;
966
967 list = ARGUMENT(0);
968
969 return (LispCopyList(builtin, list, COPY_LIST));
970 }
971
972 LispObj *
Lisp_CopyTree(LispBuiltin * builtin)973 Lisp_CopyTree(LispBuiltin *builtin)
974 /*
975 copy-tree list
976 */
977 {
978 LispObj *list;
979
980 list = ARGUMENT(0);
981
982 return (LispCopyList(builtin, list, COPY_TREE));
983 }
984
985 LispObj *
Lisp_Cons(LispBuiltin * builtin)986 Lisp_Cons(LispBuiltin *builtin)
987 /*
988 cons car cdr
989 */
990 {
991 LispObj *car, *cdr;
992
993 cdr = ARGUMENT(1);
994 car = ARGUMENT(0);
995
996 return (CONS(car, cdr));
997 }
998
999 LispObj *
Lisp_Consp(LispBuiltin * builtin)1000 Lisp_Consp(LispBuiltin *builtin)
1001 /*
1002 consp object
1003 */
1004 {
1005 LispObj *object;
1006
1007 object = ARGUMENT(0);
1008
1009 return (CONSP(object) ? T : NIL);
1010 }
1011
1012 LispObj *
Lisp_Constantp(LispBuiltin * builtin)1013 Lisp_Constantp(LispBuiltin *builtin)
1014 /*
1015 constantp form &optional environment
1016 */
1017 {
1018 LispObj *form;
1019
1020 form = ARGUMENT(0);
1021
1022 /* not all self-evaluating objects are considered constants */
1023 if (!POINTERP(form) ||
1024 NUMBERP(form) ||
1025 XQUOTEP(form) ||
1026 (XCONSP(form) && CAR(form) == Oquote) ||
1027 (XSYMBOLP(form) && form->data.atom->constant) ||
1028 XSTRINGP(form) ||
1029 XARRAYP(form))
1030 return (T);
1031
1032 return (NIL);
1033 }
1034
1035 LispObj *
Lisp_Defconstant(LispBuiltin * builtin)1036 Lisp_Defconstant(LispBuiltin *builtin)
1037 /*
1038 defconstant name initial-value &optional documentation
1039 */
1040 {
1041 LispObj *name, *initial_value, *documentation;
1042
1043 documentation = ARGUMENT(2);
1044 initial_value = ARGUMENT(1);
1045 name = ARGUMENT(0);
1046
1047 CHECK_SYMBOL(name);
1048 if (documentation != UNSPEC) {
1049 CHECK_STRING(documentation);
1050 }
1051 else
1052 documentation = NIL;
1053 LispDefconstant(name, EVAL(initial_value), documentation);
1054
1055 return (name);
1056 }
1057
1058 LispObj *
Lisp_Defmacro(LispBuiltin * builtin)1059 Lisp_Defmacro(LispBuiltin *builtin)
1060 /*
1061 defmacro name lambda-list &rest body
1062 */
1063 {
1064 LispArgList *alist;
1065
1066 LispObj *lambda, *name, *lambda_list, *body;
1067
1068 body = ARGUMENT(2);
1069 lambda_list = ARGUMENT(1);
1070 name = ARGUMENT(0);
1071
1072 CHECK_SYMBOL(name);
1073 alist = LispCheckArguments(LispMacro, lambda_list, ATOMID(name)->value, 0);
1074
1075 if (CONSP(body) && STRINGP(CAR(body))) {
1076 LispAddDocumentation(name, CAR(body), LispDocFunction);
1077 body = CDR(body);
1078 }
1079
1080 lambda_list = LispListProtectedArguments(alist);
1081 lambda = LispNewLambda(name, body, lambda_list, LispMacro);
1082
1083 if (name->data.atom->a_builtin || name->data.atom->a_compiled) {
1084 if (name->data.atom->a_builtin) {
1085 ERROR_CHECK_SPECIAL_FORM(name->data.atom);
1086 }
1087 /* redefining these may cause surprises if bytecode
1088 * compiled functions references them */
1089 LispWarning("%s: %s is being redefined", STRFUN(builtin),
1090 ATOMID(name)->value);
1091
1092 LispRemAtomBuiltinProperty(name->data.atom);
1093 }
1094
1095 LispSetAtomFunctionProperty(name->data.atom, lambda, alist);
1096 LispUseArgList(alist);
1097
1098 return (name);
1099 }
1100
1101 LispObj *
Lisp_Defun(LispBuiltin * builtin)1102 Lisp_Defun(LispBuiltin *builtin)
1103 /*
1104 defun name lambda-list &rest body
1105 */
1106 {
1107 LispArgList *alist;
1108
1109 LispObj *lambda, *name, *lambda_list, *body;
1110
1111 body = ARGUMENT(2);
1112 lambda_list = ARGUMENT(1);
1113 name = ARGUMENT(0);
1114
1115 CHECK_SYMBOL(name);
1116 alist = LispCheckArguments(LispFunction, lambda_list, ATOMID(name)->value, 0);
1117
1118 if (CONSP(body) && STRINGP(CAR(body))) {
1119 LispAddDocumentation(name, CAR(body), LispDocFunction);
1120 body = CDR(body);
1121 }
1122
1123 lambda_list = LispListProtectedArguments(alist);
1124 lambda = LispNewLambda(name, body, lambda_list, LispFunction);
1125
1126 if (name->data.atom->a_builtin || name->data.atom->a_compiled) {
1127 if (name->data.atom->a_builtin) {
1128 ERROR_CHECK_SPECIAL_FORM(name->data.atom);
1129 }
1130 /* redefining these may cause surprises if bytecode
1131 * compiled functions references them */
1132 LispWarning("%s: %s is being redefined", STRFUN(builtin),
1133 ATOMID(name)->value);
1134
1135 LispRemAtomBuiltinProperty(name->data.atom);
1136 }
1137 LispSetAtomFunctionProperty(name->data.atom, lambda, alist);
1138 LispUseArgList(alist);
1139
1140 return (name);
1141 }
1142
1143 LispObj *
Lisp_Defsetf(LispBuiltin * builtin)1144 Lisp_Defsetf(LispBuiltin *builtin)
1145 /*
1146 defsetf function lambda-list &rest body
1147 */
1148 {
1149 LispArgList *alist;
1150 LispObj *obj;
1151 LispObj *lambda, *function, *lambda_list, *store, *body;
1152
1153 body = ARGUMENT(2);
1154 lambda_list = ARGUMENT(1);
1155 function = ARGUMENT(0);
1156
1157 CHECK_SYMBOL(function);
1158
1159 if (body == NIL || (CONSP(body) && STRINGP(CAR(body)))) {
1160 if (!SYMBOLP(lambda_list))
1161 LispDestroy("%s: syntax error %s %s",
1162 STRFUN(builtin), STROBJ(function), STROBJ(lambda_list));
1163 if (body != NIL)
1164 LispAddDocumentation(function, CAR(body), LispDocSetf);
1165
1166 LispSetAtomSetfProperty(function->data.atom, lambda_list, NULL);
1167
1168 return (function);
1169 }
1170
1171 alist = LispCheckArguments(LispSetf, lambda_list, ATOMID(function)->value, 0);
1172
1173 store = CAR(body);
1174 if (!CONSP(store))
1175 LispDestroy("%s: %s is a bad store value",
1176 STRFUN(builtin), STROBJ(store));
1177 for (obj = store; CONSP(obj); obj = CDR(obj)) {
1178 CHECK_SYMBOL(CAR(obj));
1179 }
1180
1181 body = CDR(body);
1182 if (CONSP(body) && STRINGP(CAR(body))) {
1183 LispAddDocumentation(function, CAR(body), LispDocSetf);
1184 body = CDR(body);
1185 }
1186
1187 lambda = LispNewLambda(function, body, store, LispSetf);
1188 LispSetAtomSetfProperty(function->data.atom, lambda, alist);
1189 LispUseArgList(alist);
1190
1191 return (function);
1192 }
1193
1194 LispObj *
Lisp_Defparameter(LispBuiltin * builtin)1195 Lisp_Defparameter(LispBuiltin *builtin)
1196 /*
1197 defparameter name initial-value &optional documentation
1198 */
1199 {
1200 LispObj *name, *initial_value, *documentation;
1201
1202 documentation = ARGUMENT(2);
1203 initial_value = ARGUMENT(1);
1204 name = ARGUMENT(0);
1205
1206 CHECK_SYMBOL(name);
1207 if (documentation != UNSPEC) {
1208 CHECK_STRING(documentation);
1209 }
1210 else
1211 documentation = NIL;
1212
1213 LispProclaimSpecial(name, EVAL(initial_value), documentation);
1214
1215 return (name);
1216 }
1217
1218 LispObj *
Lisp_Defvar(LispBuiltin * builtin)1219 Lisp_Defvar(LispBuiltin *builtin)
1220 /*
1221 defvar name &optional initial-value documentation
1222 */
1223 {
1224 LispObj *name, *initial_value, *documentation;
1225
1226 documentation = ARGUMENT(2);
1227 initial_value = ARGUMENT(1);
1228 name = ARGUMENT(0);
1229
1230 CHECK_SYMBOL(name);
1231 if (documentation != UNSPEC) {
1232 CHECK_STRING(documentation);
1233 }
1234 else
1235 documentation = NIL;
1236
1237 LispProclaimSpecial(name,
1238 initial_value != UNSPEC ? EVAL(initial_value) : NULL,
1239 documentation);
1240
1241 return (name);
1242 }
1243
1244 LispObj *
Lisp_Delete(LispBuiltin * builtin)1245 Lisp_Delete(LispBuiltin *builtin)
1246 /*
1247 delete item sequence &key from-end test test-not start end count key
1248 */
1249 {
1250 return (LispDeleteRemoveXSubstitute(builtin, DELETE, NONE));
1251 }
1252
1253 LispObj *
Lisp_DeleteIf(LispBuiltin * builtin)1254 Lisp_DeleteIf(LispBuiltin *builtin)
1255 /*
1256 delete-if predicate sequence &key from-end start end count key
1257 */
1258 {
1259 return (LispDeleteRemoveXSubstitute(builtin, DELETE, IF));
1260 }
1261
1262 LispObj *
Lisp_DeleteIfNot(LispBuiltin * builtin)1263 Lisp_DeleteIfNot(LispBuiltin *builtin)
1264 /*
1265 delete-if-not predicate sequence &key from-end start end count key
1266 */
1267 {
1268 return (LispDeleteRemoveXSubstitute(builtin, DELETE, IFNOT));
1269 }
1270
1271 LispObj *
Lisp_DeleteDuplicates(LispBuiltin * builtin)1272 Lisp_DeleteDuplicates(LispBuiltin *builtin)
1273 /*
1274 delete-duplicates sequence &key from-end test test-not start end key
1275 */
1276 {
1277 return (LispDeleteOrRemoveDuplicates(builtin, DELETE));
1278 }
1279
1280 LispObj *
Lisp_Do(LispBuiltin * builtin)1281 Lisp_Do(LispBuiltin *builtin)
1282 /*
1283 do init test &rest body
1284 */
1285 {
1286 return (LispDo(builtin, 0));
1287 }
1288
1289 LispObj *
Lisp_DoP(LispBuiltin * builtin)1290 Lisp_DoP(LispBuiltin *builtin)
1291 /*
1292 do* init test &rest body
1293 */
1294 {
1295 return (LispDo(builtin, 1));
1296 }
1297
1298 static LispDocType_t
LispDocumentationType(LispBuiltin * builtin,LispObj * type)1299 LispDocumentationType(LispBuiltin *builtin, LispObj *type)
1300 {
1301 Atom_id atom;
1302 LispDocType_t doc_type = LispDocVariable;
1303
1304 CHECK_SYMBOL(type);
1305 atom = ATOMID(type);
1306
1307 if (atom == Svariable)
1308 doc_type = LispDocVariable;
1309 else if (atom == Sfunction)
1310 doc_type = LispDocFunction;
1311 else if (atom == Sstructure)
1312 doc_type = LispDocStructure;
1313 else if (atom == Stype)
1314 doc_type = LispDocType;
1315 else if (atom == Ssetf)
1316 doc_type = LispDocSetf;
1317 else {
1318 LispDestroy("%s: unknown documentation type %s",
1319 STRFUN(builtin), STROBJ(type));
1320 /*NOTREACHED*/
1321 }
1322
1323 return (doc_type);
1324 }
1325
1326 LispObj *
Lisp_Documentation(LispBuiltin * builtin)1327 Lisp_Documentation(LispBuiltin *builtin)
1328 /*
1329 documentation symbol type
1330 */
1331 {
1332 LispObj *symbol, *type;
1333
1334 type = ARGUMENT(1);
1335 symbol = ARGUMENT(0);
1336
1337 CHECK_SYMBOL(symbol);
1338 /* type is checked in LispDocumentationType() */
1339
1340 return (LispGetDocumentation(symbol, LispDocumentationType(builtin, type)));
1341 }
1342
1343 LispObj *
Lisp_DoList(LispBuiltin * builtin)1344 Lisp_DoList(LispBuiltin *builtin)
1345 {
1346 return (LispDoListTimes(builtin, 0));
1347 }
1348
1349 LispObj *
Lisp_DoTimes(LispBuiltin * builtin)1350 Lisp_DoTimes(LispBuiltin *builtin)
1351 {
1352 return (LispDoListTimes(builtin, 1));
1353 }
1354
1355 LispObj *
Lisp_Elt(LispBuiltin * builtin)1356 Lisp_Elt(LispBuiltin *builtin)
1357 /*
1358 elt sequence index
1359 svref sequence index
1360 */
1361 {
1362 long offset, length;
1363 LispObj *result, *sequence, *oindex;
1364
1365 oindex = ARGUMENT(1);
1366 sequence = ARGUMENT(0);
1367
1368 length = LispLength(sequence);
1369
1370 CHECK_INDEX(oindex);
1371 offset = FIXNUM_VALUE(oindex);
1372
1373 if (offset >= length)
1374 LispDestroy("%s: index %ld too large for sequence length %ld",
1375 STRFUN(builtin), offset, length);
1376
1377 if (STRINGP(sequence))
1378 result = SCHAR(THESTR(sequence)[offset]);
1379 else {
1380 if (ARRAYP(sequence))
1381 sequence = sequence->data.array.list;
1382
1383 for (; offset > 0; offset--, sequence = CDR(sequence))
1384 ;
1385 result = CAR(sequence);
1386 }
1387
1388 return (result);
1389 }
1390
1391 LispObj *
Lisp_Endp(LispBuiltin * builtin)1392 Lisp_Endp(LispBuiltin *builtin)
1393 /*
1394 endp object
1395 */
1396 {
1397 LispObj *object;
1398
1399 object = ARGUMENT(0);
1400
1401 if (object == NIL)
1402 return (T);
1403 CHECK_CONS(object);
1404
1405 return (NIL);
1406 }
1407
1408 LispObj *
Lisp_Eq(LispBuiltin * builtin)1409 Lisp_Eq(LispBuiltin *builtin)
1410 /*
1411 eq left right
1412 */
1413 {
1414 LispObj *left, *right;
1415
1416 right = ARGUMENT(1);
1417 left = ARGUMENT(0);
1418
1419 return (XEQ(left, right));
1420 }
1421
1422 LispObj *
Lisp_Eql(LispBuiltin * builtin)1423 Lisp_Eql(LispBuiltin *builtin)
1424 /*
1425 eql left right
1426 */
1427 {
1428 LispObj *left, *right;
1429
1430 right = ARGUMENT(1);
1431 left = ARGUMENT(0);
1432
1433 return (XEQL(left, right));
1434 }
1435
1436 LispObj *
Lisp_Equal(LispBuiltin * builtin)1437 Lisp_Equal(LispBuiltin *builtin)
1438 /*
1439 equal left right
1440 */
1441 {
1442 LispObj *left, *right;
1443
1444 right = ARGUMENT(1);
1445 left = ARGUMENT(0);
1446
1447 return (XEQUAL(left, right));
1448 }
1449
1450 LispObj *
Lisp_Equalp(LispBuiltin * builtin)1451 Lisp_Equalp(LispBuiltin *builtin)
1452 /*
1453 equalp left right
1454 */
1455 {
1456 LispObj *left, *right;
1457
1458 right = ARGUMENT(1);
1459 left = ARGUMENT(0);
1460
1461 return (XEQUALP(left, right));
1462 }
1463
1464 LispObj *
Lisp_Error(LispBuiltin * builtin)1465 Lisp_Error(LispBuiltin *builtin)
1466 /*
1467 error control-string &rest arguments
1468 */
1469 {
1470 LispObj *string, *arglist;
1471
1472 LispObj *control_string, *arguments;
1473
1474 arguments = ARGUMENT(1);
1475 control_string = ARGUMENT(0);
1476
1477 arglist = CONS(NIL, CONS(control_string, arguments));
1478 GC_PROTECT(arglist);
1479 string = APPLY(Oformat, arglist);
1480 LispDestroy("%s", THESTR(string));
1481 /*NOTREACHED*/
1482
1483 /* No need to call GC_ENTER() and GC_LEAVE() macros */
1484 return (NIL);
1485 }
1486
1487 LispObj *
Lisp_Eval(LispBuiltin * builtin)1488 Lisp_Eval(LispBuiltin *builtin)
1489 /*
1490 eval form
1491 */
1492 {
1493 int lex;
1494 LispObj *form, *result;
1495
1496 form = ARGUMENT(0);
1497
1498 /* make sure eval form will not access local variables */
1499 lex = lisp__data.env.lex;
1500 lisp__data.env.lex = lisp__data.env.length;
1501 result = EVAL(form);
1502 lisp__data.env.lex = lex;
1503
1504 return (result);
1505 }
1506
1507 static LispObj *
LispEverySomeAnyNot(LispBuiltin * builtin,int function)1508 LispEverySomeAnyNot(LispBuiltin *builtin, int function)
1509 /*
1510 every predicate sequence &rest more-sequences
1511 some predicate sequence &rest more-sequences
1512 notevery predicate sequence &rest more-sequences
1513 notany predicate sequence &rest more-sequences
1514 */
1515 {
1516 GC_ENTER();
1517 long i, j, length, count;
1518 LispObj *result, *list, *item, *arguments, *acons, *value;
1519 SeqInfo stk[8], *seqs;
1520
1521 LispObj *predicate, *sequence, *more_sequences;
1522
1523 more_sequences = ARGUMENT(2);
1524 sequence = ARGUMENT(1);
1525 predicate = ARGUMENT(0);
1526
1527 count = 1;
1528 length = LispLength(sequence);
1529 for (list = more_sequences; CONSP(list); list = CDR(list), count++) {
1530 i = LispLength(CAR(list));
1531 if (i < length)
1532 length = i;
1533 }
1534
1535 result = function == EVERY || function == NOTANY ? T : NIL;
1536
1537 /* if at least one sequence has length zero */
1538 if (length == 0)
1539 return (result);
1540
1541 if (count > sizeof(stk) / sizeof(stk[0]))
1542 seqs = LispMalloc(count * sizeof(SeqInfo));
1543 else
1544 seqs = &stk[0];
1545
1546 /* build information about sequences */
1547 SETSEQ(seqs[0], sequence);
1548 for (i = 1, list = more_sequences; CONSP(list); list = CDR(list), i++) {
1549 item = CAR(list);
1550 SETSEQ(seqs[i], item);
1551 }
1552
1553 /* prepare argument list */
1554 arguments = acons = CONS(NIL, NIL);
1555 GC_PROTECT(arguments);
1556 for (i = 1; i < count; i++) {
1557 RPLACD(acons, CONS(NIL, NIL));
1558 acons = CDR(acons);
1559 }
1560
1561 /* loop applying predicate in sequence elements */
1562 for (i = 0; i < length; i++) {
1563
1564 /* build argument list */
1565 for (acons = arguments, j = 0; j < count; acons = CDR(acons), j++) {
1566 if (seqs[j].type == LispString_t)
1567 item = SCHAR(*seqs[j].data.string++);
1568 else {
1569 item = CAR(seqs[j].data.list);
1570 seqs[j].data.list = CDR(seqs[j].data.list);
1571 }
1572 RPLACA(acons, item);
1573 }
1574
1575 /* apply predicate */
1576 value = APPLY(predicate, arguments);
1577
1578 /* check if needs to terminate loop */
1579 if (value == NIL) {
1580 if (function == EVERY) {
1581 result = NIL;
1582 break;
1583 }
1584 if (function == NOTEVERY) {
1585 result = T;
1586 break;
1587 }
1588 }
1589 else {
1590 if (function == SOME) {
1591 result = value;
1592 break;
1593 }
1594 if (function == NOTANY) {
1595 result = NIL;
1596 break;
1597 }
1598 }
1599 }
1600
1601 GC_LEAVE();
1602 if (seqs != &stk[0])
1603 LispFree(seqs);
1604
1605 return (result);
1606 }
1607
1608 LispObj *
Lisp_Every(LispBuiltin * builtin)1609 Lisp_Every(LispBuiltin *builtin)
1610 /*
1611 every predicate sequence &rest more-sequences
1612 */
1613 {
1614 return (LispEverySomeAnyNot(builtin, EVERY));
1615 }
1616
1617 LispObj *
Lisp_Some(LispBuiltin * builtin)1618 Lisp_Some(LispBuiltin *builtin)
1619 /*
1620 some predicate sequence &rest more-sequences
1621 */
1622 {
1623 return (LispEverySomeAnyNot(builtin, SOME));
1624 }
1625
1626 LispObj *
Lisp_Notevery(LispBuiltin * builtin)1627 Lisp_Notevery(LispBuiltin *builtin)
1628 /*
1629 notevery predicate sequence &rest more-sequences
1630 */
1631 {
1632 return (LispEverySomeAnyNot(builtin, NOTEVERY));
1633 }
1634
1635 LispObj *
Lisp_Notany(LispBuiltin * builtin)1636 Lisp_Notany(LispBuiltin *builtin)
1637 /*
1638 notany predicate sequence &rest more-sequences
1639 */
1640 {
1641 return (LispEverySomeAnyNot(builtin, NOTANY));
1642 }
1643
1644 LispObj *
Lisp_Fboundp(LispBuiltin * builtin)1645 Lisp_Fboundp(LispBuiltin *builtin)
1646 /*
1647 fboundp symbol
1648 */
1649 {
1650 LispAtom *atom;
1651
1652 LispObj *symbol = ARGUMENT(0);
1653
1654 CHECK_SYMBOL(symbol);
1655
1656 atom = symbol->data.atom;
1657 if (atom->a_function || atom->a_builtin || atom->a_compiled)
1658 return (T);
1659
1660 return (NIL);
1661 }
1662
1663 LispObj *
Lisp_Find(LispBuiltin * builtin)1664 Lisp_Find(LispBuiltin *builtin)
1665 /*
1666 find item sequence &key from-end test test-not start end key
1667 */
1668 {
1669 return (LispFindOrPosition(builtin, FIND, NONE));
1670 }
1671
1672 LispObj *
Lisp_FindIf(LispBuiltin * builtin)1673 Lisp_FindIf(LispBuiltin *builtin)
1674 /*
1675 find-if predicate sequence &key from-end start end key
1676 */
1677 {
1678 return (LispFindOrPosition(builtin, FIND, IF));
1679 }
1680
1681 LispObj *
Lisp_FindIfNot(LispBuiltin * builtin)1682 Lisp_FindIfNot(LispBuiltin *builtin)
1683 /*
1684 find-if-not predicate sequence &key from-end start end key
1685 */
1686 {
1687 return (LispFindOrPosition(builtin, FIND, IFNOT));
1688 }
1689
1690 LispObj *
Lisp_Fill(LispBuiltin * builtin)1691 Lisp_Fill(LispBuiltin *builtin)
1692 /*
1693 fill sequence item &key start end
1694 */
1695 {
1696 long i, start, end, length;
1697
1698 LispObj *sequence, *item, *ostart, *oend;
1699
1700 oend = ARGUMENT(3);
1701 ostart = ARGUMENT(2);
1702 item = ARGUMENT(1);
1703 sequence = ARGUMENT(0);
1704
1705 LispCheckSequenceStartEnd(builtin, sequence, ostart, oend,
1706 &start, &end, &length);
1707
1708 if (STRINGP(sequence)) {
1709 int ch;
1710 char *string = THESTR(sequence);
1711
1712 CHECK_STRING_WRITABLE(sequence);
1713 CHECK_SCHAR(item);
1714 ch = SCHAR_VALUE(item);
1715 for (i = start; i < end; i++)
1716 string[i] = ch;
1717 }
1718 else {
1719 LispObj *list;
1720
1721 if (CONSP(sequence))
1722 list = sequence;
1723 else
1724 list = sequence->data.array.list;
1725
1726 for (i = 0; i < start; i++, list = CDR(list))
1727 ;
1728 for (; i < end; i++, list = CDR(list))
1729 RPLACA(list, item);
1730 }
1731
1732 return (sequence);
1733 }
1734
1735 LispObj *
Lisp_Fmakunbound(LispBuiltin * builtin)1736 Lisp_Fmakunbound(LispBuiltin *builtin)
1737 /*
1738 fmkaunbound symbol
1739 */
1740 {
1741 LispObj *symbol;
1742
1743 symbol = ARGUMENT(0);
1744
1745 CHECK_SYMBOL(symbol);
1746 if (symbol->data.atom->a_function)
1747 LispRemAtomFunctionProperty(symbol->data.atom);
1748 else if (symbol->data.atom->a_builtin)
1749 LispRemAtomBuiltinProperty(symbol->data.atom);
1750 else if (symbol->data.atom->a_compiled)
1751 LispRemAtomCompiledProperty(symbol->data.atom);
1752
1753 return (symbol);
1754 }
1755
1756 LispObj *
Lisp_Funcall(LispBuiltin * builtin)1757 Lisp_Funcall(LispBuiltin *builtin)
1758 /*
1759 funcall function &rest arguments
1760 */
1761 {
1762 LispObj *result;
1763
1764 LispObj *function, *arguments;
1765
1766 arguments = ARGUMENT(1);
1767 function = ARGUMENT(0);
1768
1769 result = APPLY(function, arguments);
1770
1771 return (result);
1772 }
1773
1774 LispObj *
Lisp_Functionp(LispBuiltin * builtin)1775 Lisp_Functionp(LispBuiltin *builtin)
1776 /*
1777 functionp object
1778 */
1779 {
1780 LispObj *object;
1781
1782 object = ARGUMENT(0);
1783
1784 return (FUNCTIONP(object) || LAMBDAP(object) ? T : NIL);
1785 }
1786
1787 LispObj *
Lisp_Get(LispBuiltin * builtin)1788 Lisp_Get(LispBuiltin *builtin)
1789 /*
1790 get symbol indicator &optional default
1791 */
1792 {
1793 LispObj *result;
1794
1795 LispObj *symbol, *indicator, *defalt;
1796
1797 defalt = ARGUMENT(2);
1798 indicator = ARGUMENT(1);
1799 symbol = ARGUMENT(0);
1800
1801 CHECK_SYMBOL(symbol);
1802
1803 result = LispGetAtomProperty(symbol->data.atom, indicator);
1804
1805 if (result != NIL)
1806 result = CAR(result);
1807 else
1808 result = defalt == UNSPEC ? NIL : defalt;
1809
1810 return (result);
1811 }
1812
1813 /*
1814 * ext::getenv
1815 */
1816 LispObj *
Lisp_Getenv(LispBuiltin * builtin)1817 Lisp_Getenv(LispBuiltin *builtin)
1818 /*
1819 getenv name
1820 */
1821 {
1822 char *value;
1823
1824 LispObj *name;
1825
1826 name = ARGUMENT(0);
1827
1828 CHECK_STRING(name);
1829 value = getenv(THESTR(name));
1830
1831 return (value ? STRING(value) : NIL);
1832 }
1833
1834 LispObj *
Lisp_Gc(LispBuiltin * builtin)1835 Lisp_Gc(LispBuiltin *builtin)
1836 /*
1837 gc &optional car cdr
1838 */
1839 {
1840 LispObj *car, *cdr;
1841
1842 cdr = ARGUMENT(1);
1843 car = ARGUMENT(0);
1844
1845 LispGC(car, cdr);
1846
1847 return (NIL);
1848 }
1849
1850 LispObj *
Lisp_Gensym(LispBuiltin * builtin)1851 Lisp_Gensym(LispBuiltin *builtin)
1852 /*
1853 gensym &optional arg
1854 */
1855 {
1856 const char *preffix = "G";
1857 char name[132];
1858 long counter = LONGINT_VALUE(Ogensym_counter->data.atom->property->value);
1859 LispObj *symbol;
1860
1861 LispObj *arg;
1862
1863 arg = ARGUMENT(0);
1864 if (arg != UNSPEC) {
1865 if (STRINGP(arg))
1866 preffix = THESTR(arg);
1867 else {
1868 CHECK_INDEX(arg);
1869 counter = FIXNUM_VALUE(arg);
1870 }
1871 }
1872 snprintf(name, sizeof(name), "%s%ld", preffix, counter);
1873 if (strlen(name) >= 128)
1874 LispDestroy("%s: name %s too long", STRFUN(builtin), name);
1875 Ogensym_counter->data.atom->property->value = INTEGER(counter + 1);
1876
1877 symbol = UNINTERNED_ATOM(name);
1878 symbol->data.atom->unreadable = !LispCheckAtomString(name);
1879
1880 return (symbol);
1881 }
1882
1883 LispObj *
Lisp_Go(LispBuiltin * builtin)1884 Lisp_Go(LispBuiltin *builtin)
1885 /*
1886 go tag
1887 */
1888 {
1889 unsigned blevel = lisp__data.block.block_level;
1890
1891 LispObj *tag;
1892
1893 tag = ARGUMENT(0);
1894
1895 while (blevel) {
1896 LispBlock *block = lisp__data.block.block[--blevel];
1897
1898 if (block->type == LispBlockClosure)
1899 /* if reached a function call */
1900 break;
1901 if (block->type == LispBlockBody) {
1902 lisp__data.block.block_ret = tag;
1903 LispBlockUnwind(block);
1904 BLOCKJUMP(block);
1905 }
1906 }
1907
1908 LispDestroy("%s: no visible tagbody for %s",
1909 STRFUN(builtin), STROBJ(tag));
1910 /*NOTREACHED*/
1911 return (NIL);
1912 }
1913
1914 LispObj *
Lisp_If(LispBuiltin * builtin)1915 Lisp_If(LispBuiltin *builtin)
1916 /*
1917 if test then &optional else
1918 */
1919 {
1920 LispObj *result, *test, *then, *oelse;
1921
1922 oelse = ARGUMENT(2);
1923 then = ARGUMENT(1);
1924 test = ARGUMENT(0);
1925
1926 test = EVAL(test);
1927 if (test != NIL)
1928 result = EVAL(then);
1929 else if (oelse != UNSPEC)
1930 result = EVAL(oelse);
1931 else
1932 result = NIL;
1933
1934 return (result);
1935 }
1936
1937 LispObj *
Lisp_IgnoreErrors(LispBuiltin * builtin)1938 Lisp_IgnoreErrors(LispBuiltin *builtin)
1939 /*
1940 ignore-erros &rest body
1941 */
1942 {
1943 LispObj *result;
1944 int i, jumped;
1945 LispBlock *block;
1946
1947 /* interpreter state */
1948 GC_ENTER();
1949 int stack, lex, length;
1950
1951 /* memory allocation */
1952 int mem_level;
1953 void **mem;
1954
1955 LispObj *body;
1956
1957 body = ARGUMENT(0);
1958
1959 /* Save environment information */
1960 stack = lisp__data.stack.length;
1961 lex = lisp__data.env.lex;
1962 length = lisp__data.env.length;
1963
1964 /* Save memory allocation information */
1965 mem_level = lisp__data.mem.level;
1966 mem = LispMalloc(mem_level * sizeof(void*));
1967 memcpy(mem, lisp__data.mem.mem, mem_level * sizeof(void*));
1968
1969 ++lisp__data.ignore_errors;
1970 result = NIL;
1971 jumped = 1;
1972 block = LispBeginBlock(NIL, LispBlockProtect);
1973 if (setjmp(block->jmp) == 0) {
1974 for (; CONSP(body); body = CDR(body))
1975 result = EVAL(CAR(body));
1976 jumped = 0;
1977 }
1978 LispEndBlock(block);
1979 if (!lisp__data.destroyed && jumped)
1980 result = lisp__data.block.block_ret;
1981
1982 if (lisp__data.destroyed) {
1983 /* Restore environment */
1984 lisp__data.stack.length = stack;
1985 lisp__data.env.lex = lex;
1986 lisp__data.env.head = lisp__data.env.length = length;
1987 GC_LEAVE();
1988
1989 /* Check for possible leaks due to ignoring errors */
1990 for (i = 0; i < mem_level; i++) {
1991 if (lisp__data.mem.mem[i] && mem[i] != lisp__data.mem.mem[i])
1992 LispFree(lisp__data.mem.mem[i]);
1993 }
1994 for (; i < lisp__data.mem.level; i++) {
1995 if (lisp__data.mem.mem[i])
1996 LispFree(lisp__data.mem.mem[i]);
1997 }
1998
1999 lisp__data.destroyed = 0;
2000 result = NIL;
2001 RETURN_COUNT = 1;
2002 RETURN(0) = lisp__data.error_condition;
2003 }
2004 LispFree(mem);
2005 --lisp__data.ignore_errors;
2006
2007 return (result);
2008 }
2009
2010 LispObj *
Lisp_Intersection(LispBuiltin * builtin)2011 Lisp_Intersection(LispBuiltin *builtin)
2012 /*
2013 intersection list1 list2 &key test test-not key
2014 */
2015 {
2016 return (LispListSet(builtin, INTERSECTION));
2017 }
2018
2019 LispObj *
Lisp_Nintersection(LispBuiltin * builtin)2020 Lisp_Nintersection(LispBuiltin *builtin)
2021 /*
2022 nintersection list1 list2 &key test test-not key
2023 */
2024 {
2025 return (LispListSet(builtin, NINTERSECTION));
2026 }
2027
2028 LispObj *
Lisp_Keywordp(LispBuiltin * builtin)2029 Lisp_Keywordp(LispBuiltin *builtin)
2030 /*
2031 keywordp object
2032 */
2033 {
2034 LispObj *object;
2035
2036 object = ARGUMENT(0);
2037
2038 return (KEYWORDP(object) ? T : NIL);
2039 }
2040
2041 LispObj *
Lisp_Lambda(LispBuiltin * builtin)2042 Lisp_Lambda(LispBuiltin *builtin)
2043 /*
2044 lambda lambda-list &rest body
2045 */
2046 {
2047 GC_ENTER();
2048 LispObj *name;
2049 LispArgList *alist;
2050
2051 LispObj *lambda, *lambda_list, *body;
2052
2053 body = ARGUMENT(1);
2054 lambda_list = ARGUMENT(0);
2055
2056 alist = LispCheckArguments(LispLambda, lambda_list, Snil->value, 0);
2057
2058 name = OPAQUE(alist, LispArgList_t);
2059 lambda_list = LispListProtectedArguments(alist);
2060 GC_PROTECT(name);
2061 GC_PROTECT(lambda_list);
2062 lambda = LispNewLambda(name, body, lambda_list, LispLambda);
2063 LispUseArgList(alist);
2064 GC_LEAVE();
2065
2066 return (lambda);
2067 }
2068
2069 LispObj *
Lisp_Last(LispBuiltin * builtin)2070 Lisp_Last(LispBuiltin *builtin)
2071 /*
2072 last list &optional count
2073 */
2074 {
2075 long count, length;
2076 LispObj *list, *ocount;
2077
2078 ocount = ARGUMENT(1);
2079 list = ARGUMENT(0);
2080
2081 if (!CONSP(list))
2082 return (list);
2083
2084 length = LispLength(list);
2085
2086 if (ocount == UNSPEC)
2087 count = 1;
2088 else {
2089 CHECK_INDEX(ocount);
2090 count = FIXNUM_VALUE(ocount);
2091 }
2092
2093 if (count >= length)
2094 return (list);
2095
2096 length -= count;
2097 for (; length > 0; length--)
2098 list = CDR(list);
2099
2100 return (list);
2101 }
2102
2103 LispObj *
Lisp_Length(LispBuiltin * builtin)2104 Lisp_Length(LispBuiltin *builtin)
2105 /*
2106 length sequence
2107 */
2108 {
2109 LispObj *sequence;
2110
2111 sequence = ARGUMENT(0);
2112
2113 return (FIXNUM(LispLength(sequence)));
2114 }
2115
2116 LispObj *
Lisp_Let(LispBuiltin * builtin)2117 Lisp_Let(LispBuiltin *builtin)
2118 /*
2119 let init &rest body
2120 */
2121 {
2122 GC_ENTER();
2123 int head = lisp__data.env.length;
2124 LispObj *init, *body, *pair, *result, *list, *cons = NIL;
2125
2126 body = ARGUMENT(1);
2127 init = ARGUMENT(0);
2128
2129 CHECK_LIST(init);
2130 for (list = NIL; CONSP(init); init = CDR(init)) {
2131 LispObj *symbol, *value;
2132
2133 pair = CAR(init);
2134 if (SYMBOLP(pair)) {
2135 symbol = pair;
2136 value = NIL;
2137 }
2138 else {
2139 CHECK_CONS(pair);
2140 symbol = CAR(pair);
2141 CHECK_SYMBOL(symbol);
2142 pair = CDR(pair);
2143 if (CONSP(pair)) {
2144 value = CAR(pair);
2145 if (CDR(pair) != NIL)
2146 LispDestroy("%s: too much arguments to initialize %s",
2147 STRFUN(builtin), STROBJ(symbol));
2148 value = EVAL(value);
2149 }
2150 else
2151 value = NIL;
2152 }
2153 pair = CONS(symbol, value);
2154 if (list == NIL) {
2155 list = cons = CONS(pair, NIL);
2156 GC_PROTECT(list);
2157 }
2158 else {
2159 RPLACD(cons, CONS(pair, NIL));
2160 cons = CDR(cons);
2161 }
2162 }
2163 /* Add variables */
2164 for (; CONSP(list); list = CDR(list)) {
2165 pair = CAR(list);
2166 CHECK_CONSTANT(CAR(pair));
2167 LispAddVar(CAR(pair), CDR(pair));
2168 ++lisp__data.env.head;
2169 }
2170 /* Values of symbols are now protected */
2171 GC_LEAVE();
2172
2173 /* execute body */
2174 for (result = NIL; CONSP(body); body = CDR(body))
2175 result = EVAL(CAR(body));
2176
2177 lisp__data.env.head = lisp__data.env.length = head;
2178
2179 return (result);
2180 }
2181
2182 LispObj *
Lisp_LetP(LispBuiltin * builtin)2183 Lisp_LetP(LispBuiltin *builtin)
2184 /*
2185 let* init &rest body
2186 */
2187 {
2188 int head = lisp__data.env.length;
2189 LispObj *init, *body, *pair, *result;
2190
2191 body = ARGUMENT(1);
2192 init = ARGUMENT(0);
2193
2194 CHECK_LIST(init);
2195 for (; CONSP(init); init = CDR(init)) {
2196 LispObj *symbol, *value;
2197
2198 pair = CAR(init);
2199 if (SYMBOLP(pair)) {
2200 symbol = pair;
2201 value = NIL;
2202 }
2203 else {
2204 CHECK_CONS(pair);
2205 symbol = CAR(pair);
2206 CHECK_SYMBOL(symbol);
2207 pair = CDR(pair);
2208 if (CONSP(pair)) {
2209 value = CAR(pair);
2210 if (CDR(pair) != NIL)
2211 LispDestroy("%s: too much arguments to initialize %s",
2212 STRFUN(builtin), STROBJ(symbol));
2213 value = EVAL(value);
2214 }
2215 else
2216 value = NIL;
2217 }
2218
2219 CHECK_CONSTANT(symbol);
2220 LispAddVar(symbol, value);
2221 ++lisp__data.env.head;
2222 }
2223
2224 /* execute body */
2225 for (result = NIL; CONSP(body); body = CDR(body))
2226 result = EVAL(CAR(body));
2227
2228 lisp__data.env.head = lisp__data.env.length = head;
2229
2230 return (result);
2231 }
2232
2233 LispObj *
Lisp_List(LispBuiltin * builtin)2234 Lisp_List(LispBuiltin *builtin)
2235 /*
2236 list &rest args
2237 */
2238 {
2239 LispObj *args;
2240
2241 args = ARGUMENT(0);
2242
2243 return (args);
2244 }
2245
2246 LispObj *
Lisp_ListP(LispBuiltin * builtin)2247 Lisp_ListP(LispBuiltin *builtin)
2248 /*
2249 list* object &rest more-objects
2250 */
2251 {
2252 GC_ENTER();
2253 LispObj *result, *cons;
2254
2255 LispObj *object, *more_objects;
2256
2257 more_objects = ARGUMENT(1);
2258 object = ARGUMENT(0);
2259
2260 if (!CONSP(more_objects))
2261 return (object);
2262
2263 result = cons = CONS(object, CAR(more_objects));
2264 GC_PROTECT(result);
2265 for (more_objects = CDR(more_objects); CONSP(more_objects);
2266 more_objects = CDR(more_objects)) {
2267 object = CAR(more_objects);
2268 RPLACD(cons, CONS(CDR(cons), object));
2269 cons = CDR(cons);
2270 }
2271 GC_LEAVE();
2272
2273 return (result);
2274 }
2275
2276 /* "classic" list-length */
2277 LispObj *
Lisp_ListLength(LispBuiltin * builtin)2278 Lisp_ListLength(LispBuiltin *builtin)
2279 /*
2280 list-length list
2281 */
2282 {
2283 long length;
2284 LispObj *fast, *slow;
2285
2286 LispObj *list;
2287
2288 list = ARGUMENT(0);
2289
2290 CHECK_LIST(list);
2291 for (fast = slow = list, length = 0;
2292 CONSP(slow);
2293 slow = CDR(slow), length += 2) {
2294 if (fast == NIL)
2295 break;
2296 CHECK_CONS(fast);
2297 fast = CDR(fast);
2298 if (fast == NIL) {
2299 ++length;
2300 break;
2301 }
2302 CHECK_CONS(fast);
2303 fast = CDR(fast);
2304 if (slow == fast)
2305 /* circular list */
2306 return (NIL);
2307 }
2308
2309 return (FIXNUM(length));
2310 }
2311
2312 LispObj *
Lisp_Listp(LispBuiltin * builtin)2313 Lisp_Listp(LispBuiltin *builtin)
2314 /*
2315 listp object
2316 */
2317 {
2318 LispObj *object;
2319
2320 object = ARGUMENT(0);
2321
2322 return (object == NIL || CONSP(object) ? T : NIL);
2323 }
2324
2325 static LispObj *
LispListSet(LispBuiltin * builtin,int function)2326 LispListSet(LispBuiltin *builtin, int function)
2327 /*
2328 intersection list1 list2 &key test test-not key
2329 nintersection list1 list2 &key test test-not key
2330 set-difference list1 list2 &key test test-not key
2331 nset-difference list1 list2 &key test test-not key
2332 set-exclusive-or list1 list2 &key test test-not key
2333 nset-exclusive-or list1 list2 &key test test-not key
2334 subsetp list1 list2 &key test test-not key
2335 union list1 list2 &key test test-not key
2336 nunion list1 list2 &key test test-not key
2337 */
2338 {
2339 GC_ENTER();
2340 int code, expect, value, inplace, check_list2,
2341 intersection, setdifference, xunion, setexclusiveor;
2342 LispObj *lambda, *result, *cmp, *cmp1, *cmp2,
2343 *item, *clist1, *clist2, *cons, *cdr;
2344
2345 LispObj *list1, *list2, *test, *test_not, *key;
2346
2347 key = ARGUMENT(4);
2348 test_not = ARGUMENT(3);
2349 test = ARGUMENT(2);
2350 list2 = ARGUMENT(1);
2351 list1 = ARGUMENT(0);
2352
2353 /* Check if arguments are valid lists */
2354 CHECK_LIST(list1);
2355 CHECK_LIST(list2);
2356
2357 setdifference = intersection = xunion = setexclusiveor = inplace = 0;
2358 switch (function) {
2359 case NSETDIFFERENCE:
2360 inplace = 1;
2361 case SETDIFFERENCE:
2362 setdifference = 1;
2363 break;
2364 case NINTERSECTION:
2365 inplace = 1;
2366 case INTERSECTION:
2367 intersection = 1;
2368 break;
2369 case NUNION:
2370 inplace = 1;
2371 case UNION:
2372 xunion = 1;
2373 break;
2374 case NSETEXCLUSIVEOR:
2375 inplace = 1;
2376 case SETEXCLUSIVEOR:
2377 setexclusiveor = 1;
2378 break;
2379 }
2380
2381 /* Check for fast return */
2382 if (list1 == NIL)
2383 return (setdifference || intersection ?
2384 NIL : function == SUBSETP ? T : list2);
2385 if (list2 == NIL)
2386 return (intersection || xunion || function == SUBSETP ? NIL : list1);
2387
2388 CHECK_TEST();
2389 clist1 = cdr = NIL;
2390
2391 /* Make a copy of list2 with the key predicate applied */
2392 if (key != UNSPEC) {
2393 result = cons = CONS(APPLY1(key, CAR(list2)), NIL);
2394 GC_PROTECT(result);
2395 for (cmp2 = CDR(list2); CONSP(cmp2); cmp2 = CDR(cmp2)) {
2396 item = APPLY1(key, CAR(cmp2));
2397 RPLACD(cons, CONS(APPLY1(key, CAR(cmp2)), NIL));
2398 cons = CDR(cons);
2399 }
2400 /* check if list2 is a proper list */
2401 CHECK_LIST(cmp2);
2402 clist2 = result;
2403 check_list2 = 0;
2404 }
2405 else {
2406 clist2 = list2;
2407 check_list2 = 1;
2408 }
2409 result = cons = NIL;
2410
2411 /* Compare elements of lists
2412 * Logic:
2413 * UNION
2414 * 1) Walk list1 and if CAR(list1) not in list2, add it to result
2415 * 2) Add list2 to result
2416 * INTERSECTION
2417 * 1) Walk list1 and if CAR(list1) in list2, add it to result
2418 * SET-DIFFERENCE
2419 * 1) Walk list1 and if CAR(list1) not in list2, add it to result
2420 * SET-EXCLUSIVE-OR
2421 * 1) Walk list1 and if CAR(list1) not in list2, add it to result
2422 * 2) Walk list2 and if CAR(list2) not in list1, add it to result
2423 * SUBSETP
2424 * 1) Walk list1 and if CAR(list1) not in list2, return NIL
2425 * 2) Return T
2426 */
2427 value = 0;
2428 for (cmp1 = list1; CONSP(cmp1); cmp1 = CDR(cmp1)) {
2429 item = CAR(cmp1);
2430
2431 /* Apply key predicate if required */
2432 if (key != UNSPEC) {
2433 cmp = APPLY1(key, item);
2434 if (setexclusiveor) {
2435 if (clist1 == NIL) {
2436 clist1 = cdr = CONS(cmp, NIL);
2437 GC_PROTECT(clist1);
2438 }
2439 else {
2440 RPLACD(cdr, CONS(cmp, NIL));
2441 cdr = CDR(cdr);
2442 }
2443 }
2444 }
2445 else
2446 cmp = item;
2447
2448 /* Compare against list2 */
2449 for (cmp2 = clist2; CONSP(cmp2); cmp2 = CDR(cmp2)) {
2450 value = FCOMPARE(lambda, cmp, CAR(cmp2), code);
2451 if (value == expect)
2452 break;
2453 }
2454 if (check_list2 && value != expect) {
2455 /* check if list2 is a proper list */
2456 CHECK_LIST(cmp2);
2457 check_list2 = 0;
2458 }
2459
2460 if (function == SUBSETP) {
2461 /* Element of list1 not in list2? */
2462 if (value != expect) {
2463 GC_LEAVE();
2464
2465 return (NIL);
2466 }
2467 }
2468 /* If need to add item to result */
2469 else if (((setdifference || xunion || setexclusiveor) &&
2470 value != expect) ||
2471 (intersection && value == expect)) {
2472 if (inplace) {
2473 if (result == NIL)
2474 result = cons = cmp1;
2475 else {
2476 if (setexclusiveor) {
2477 /* don't remove elements yet, will need
2478 * to check agains't list2 later */
2479 for (cmp2 = cons; CDR(cmp2) != cmp1; cmp2 = CDR(cmp2))
2480 ;
2481 if (cmp2 != cons) {
2482 RPLACD(cmp2, list1);
2483 list1 = cmp2;
2484 }
2485 }
2486 RPLACD(cons, cmp1);
2487 cons = cmp1;
2488 }
2489 }
2490 else {
2491 if (result == NIL) {
2492 result = cons = CONS(item, NIL);
2493 GC_PROTECT(result);
2494 }
2495 else {
2496 RPLACD(cons, CONS(item, NIL));
2497 cons = CDR(cons);
2498 }
2499 }
2500 }
2501 }
2502 /* check if list1 is a proper list */
2503 CHECK_LIST(cmp1);
2504
2505 if (function == SUBSETP) {
2506 GC_LEAVE();
2507
2508 return (T);
2509 }
2510 else if (xunion) {
2511 /* Add list2 to tail of result */
2512 if (result == NIL)
2513 result = list2;
2514 else
2515 RPLACD(cons, list2);
2516 }
2517 else if (setexclusiveor) {
2518 LispObj *result2, *cons2;
2519
2520 result2 = cons2 = NIL;
2521 for (cmp2 = list2; CONSP(cmp2); cmp2 = CDR(cmp2)) {
2522 item = CAR(cmp2);
2523
2524 if (key != UNSPEC) {
2525 cmp = CAR(clist2);
2526 /* XXX changing clist2 */
2527 clist2 = CDR(clist2);
2528 cmp1 = clist1;
2529 }
2530 else {
2531 cmp = item;
2532 cmp1 = list1;
2533 }
2534
2535 /* Compare against list1 */
2536 for (; CONSP(cmp1); cmp1 = CDR(cmp1)) {
2537 value = FCOMPARE(lambda, cmp, CAR(cmp1), code);
2538 if (value == expect)
2539 break;
2540 }
2541
2542 if (value != expect) {
2543 if (inplace) {
2544 if (result2 == NIL)
2545 result2 = cons2 = cmp2;
2546 else {
2547 RPLACD(cons2, cmp2);
2548 cons2 = cmp2;
2549 }
2550 }
2551 else {
2552 if (result == NIL) {
2553 result = cons = CONS(item, NIL);
2554 GC_PROTECT(result);
2555 }
2556 else {
2557 RPLACD(cons, CONS(item, NIL));
2558 cons = CDR(cons);
2559 }
2560 }
2561 }
2562 }
2563 if (inplace) {
2564 if (CONSP(cons2))
2565 RPLACD(cons2, NIL);
2566 if (result == NIL)
2567 result = result2;
2568 else
2569 RPLACD(cons, result2);
2570 }
2571 }
2572 else if ((function == NSETDIFFERENCE || function == NINTERSECTION) &&
2573 CONSP(cons))
2574 RPLACD(cons, NIL);
2575
2576 GC_LEAVE();
2577
2578 return (result);
2579 }
2580
2581 LispObj *
Lisp_Loop(LispBuiltin * builtin)2582 Lisp_Loop(LispBuiltin *builtin)
2583 /*
2584 loop &rest body
2585 */
2586 {
2587 LispObj *code, *result;
2588 LispBlock *block;
2589
2590 LispObj *body;
2591
2592 body = ARGUMENT(0);
2593
2594 result = NIL;
2595 block = LispBeginBlock(NIL, LispBlockTag);
2596 if (setjmp(block->jmp) == 0) {
2597 for (;;)
2598 for (code = body; CONSP(code); code = CDR(code))
2599 (void)EVAL(CAR(code));
2600 }
2601 LispEndBlock(block);
2602 result = lisp__data.block.block_ret;
2603
2604 return (result);
2605 }
2606
2607 /* XXX This function is broken, needs a review
2608 (being delayed until true array/vectors be implemented) */
2609 LispObj *
Lisp_MakeArray(LispBuiltin * builtin)2610 Lisp_MakeArray(LispBuiltin *builtin)
2611 /*
2612 make-array dimensions &key element-type initial-element initial-contents
2613 adjustable fill-pointer displaced-to
2614 displaced-index-offset
2615 */
2616 {
2617 long rank = 0, count = 1, offset, zero, c;
2618 LispObj *obj, *dim, *array;
2619 LispType type;
2620
2621 LispObj *dimensions, *element_type, *initial_element, *initial_contents,
2622 *displaced_to, *displaced_index_offset;
2623
2624 dim = array = NIL;
2625 type = LispNil_t;
2626
2627 displaced_index_offset = ARGUMENT(7);
2628 displaced_to = ARGUMENT(6);
2629 initial_contents = ARGUMENT(3);
2630 initial_element = ARGUMENT(2);
2631 element_type = ARGUMENT(1);
2632 dimensions = ARGUMENT(0);
2633
2634 if (INDEXP(dimensions)) {
2635 dim = CONS(dimensions, NIL);
2636 rank = 1;
2637 count = FIXNUM_VALUE(dimensions);
2638 }
2639 else if (CONSP(dimensions)) {
2640 dim = dimensions;
2641
2642 for (rank = 0; CONSP(dim); rank++, dim = CDR(dim)) {
2643 obj = CAR(dim);
2644 CHECK_INDEX(obj);
2645 count *= FIXNUM_VALUE(obj);
2646 }
2647 dim = dimensions;
2648 }
2649 else if (dimensions == NIL) {
2650 dim = NIL;
2651 rank = count = 0;
2652 }
2653 else
2654 LispDestroy("%s: %s is a bad array dimension",
2655 STRFUN(builtin), STROBJ(dimensions));
2656
2657 /* check element-type */
2658 if (element_type != UNSPEC) {
2659 if (element_type == T)
2660 type = LispNil_t;
2661 else if (!SYMBOLP(element_type))
2662 LispDestroy("%s: unsupported element type %s",
2663 STRFUN(builtin), STROBJ(element_type));
2664 else {
2665 Atom_id atom = ATOMID(element_type);
2666
2667 if (atom == Satom)
2668 type = LispAtom_t;
2669 else if (atom == Sinteger)
2670 type = LispInteger_t;
2671 else if (atom == Scharacter)
2672 type = LispSChar_t;
2673 else if (atom == Sstring)
2674 type = LispString_t;
2675 else if (atom == Slist)
2676 type = LispCons_t;
2677 else if (atom == Sopaque)
2678 type = LispOpaque_t;
2679 else
2680 LispDestroy("%s: unsupported element type %s",
2681 STRFUN(builtin), ATOMID(element_type)->value);
2682 }
2683 }
2684
2685 /* check initial-contents */
2686 if (rank) {
2687 CHECK_LIST(initial_contents);
2688 }
2689
2690 /* check displaced-to */
2691 if (displaced_to != UNSPEC) {
2692 CHECK_ARRAY(displaced_to);
2693 }
2694
2695 /* check displaced-index-offset */
2696 offset = -1;
2697 if (displaced_index_offset != UNSPEC) {
2698 CHECK_INDEX(displaced_index_offset);
2699 offset = FIXNUM_VALUE(displaced_index_offset);
2700 }
2701
2702 c = 0;
2703 if (initial_element != UNSPEC)
2704 ++c;
2705 if (initial_contents != UNSPEC)
2706 ++c;
2707 if (displaced_to != UNSPEC || offset >= 0)
2708 ++c;
2709 if (c > 1)
2710 LispDestroy("%s: more than one initialization specified",
2711 STRFUN(builtin));
2712 if (initial_element == UNSPEC)
2713 initial_element = NIL;
2714
2715 zero = count == 0;
2716 if (displaced_to != UNSPEC) {
2717 CHECK_ARRAY(displaced_to);
2718 if (offset < 0)
2719 offset = 0;
2720 for (c = 1, obj = displaced_to->data.array.dim; obj != NIL;
2721 obj = CDR(obj))
2722 c *= FIXNUM_VALUE(CAR(obj));
2723 if (c < count + offset)
2724 LispDestroy("%s: array-total-size + displaced-index-offset "
2725 "exceeds total size", STRFUN(builtin));
2726 for (c = 0, array = displaced_to->data.array.list; c < offset; c++)
2727 array = CDR(array);
2728 }
2729 else if (initial_contents != UNSPEC) {
2730 CHECK_CONS(initial_contents);
2731 if (rank == 0)
2732 array = initial_contents;
2733 else if (rank == 1) {
2734 for (array = initial_contents, c = 0; c < count;
2735 array = CDR(array), c++)
2736 if (!CONSP(array))
2737 LispDestroy("%s: bad argument or size %s",
2738 STRFUN(builtin), STROBJ(array));
2739 if (array != NIL)
2740 LispDestroy("%s: bad argument or size %s",
2741 STRFUN(builtin), STROBJ(array));
2742 array = initial_contents;
2743 }
2744 else {
2745 LispObj *err = NIL;
2746 /* check if list matches */
2747 int i, j, k, *dims, *loop;
2748
2749 /* create iteration variables */
2750 dims = LispMalloc(sizeof(int) * rank);
2751 loop = LispCalloc(1, sizeof(int) * (rank - 1));
2752 for (i = 0, obj = dim; CONSP(obj); i++, obj = CDR(obj))
2753 dims[i] = FIXNUM_VALUE(CAR(obj));
2754
2755 /* check if list matches specified dimensions */
2756 while (loop[0] < dims[0]) {
2757 for (obj = initial_contents, i = 0; i < rank - 1; i++) {
2758 for (j = 0; j < loop[i]; j++)
2759 obj = CDR(obj);
2760 err = obj;
2761 if (!CONSP(obj = CAR(obj)))
2762 goto make_array_error;
2763 err = obj;
2764 }
2765 --i;
2766 for (;;) {
2767 ++loop[i];
2768 if (i && loop[i] >= dims[i])
2769 loop[i] = 0;
2770 else
2771 break;
2772 --i;
2773 }
2774 for (k = 0; k < dims[rank - 1]; obj = CDR(obj), k++) {
2775 if (!CONSP(obj))
2776 goto make_array_error;
2777 }
2778 if (obj == NIL)
2779 continue;
2780 make_array_error:
2781 LispFree(dims);
2782 LispFree(loop);
2783 LispDestroy("%s: bad argument or size %s",
2784 STRFUN(builtin), STROBJ(err));
2785 }
2786
2787 /* list is correct, use it to fill initial values */
2788
2789 /* reset loop */
2790 memset(loop, 0, sizeof(int) * (rank - 1));
2791
2792 GCDisable();
2793 /* fill array with supplied values */
2794 array = NIL;
2795 while (loop[0] < dims[0]) {
2796 for (obj = initial_contents, i = 0; i < rank - 1; i++) {
2797 for (j = 0; j < loop[i]; j++)
2798 obj = CDR(obj);
2799 obj = CAR(obj);
2800 }
2801 --i;
2802 for (;;) {
2803 ++loop[i];
2804 if (i && loop[i] >= dims[i])
2805 loop[i] = 0;
2806 else
2807 break;
2808 --i;
2809 }
2810 for (k = 0; k < dims[rank - 1]; obj = CDR(obj), k++) {
2811 if (array == NIL)
2812 array = CONS(CAR(obj), NIL);
2813 else {
2814 RPLACD(array, CONS(CAR(array), CDR(array)));
2815 RPLACA(array, CAR(obj));
2816 }
2817 }
2818 }
2819 LispFree(dims);
2820 LispFree(loop);
2821 array = LispReverse(array);
2822 GCEnable();
2823 }
2824 }
2825 else {
2826 GCDisable();
2827 /* allocate array */
2828 if (count) {
2829 --count;
2830 array = CONS(initial_element, NIL);
2831 while (count) {
2832 RPLACD(array, CONS(CAR(array), CDR(array)));
2833 RPLACA(array, initial_element);
2834 count--;
2835 }
2836 }
2837 GCEnable();
2838 }
2839
2840 obj = LispNew(array, dim);
2841 obj->type = LispArray_t;
2842 obj->data.array.list = array;
2843 obj->data.array.dim = dim;
2844 obj->data.array.rank = rank;
2845 obj->data.array.type = type;
2846 obj->data.array.zero = zero;
2847
2848 return (obj);
2849 }
2850
2851 LispObj *
Lisp_MakeList(LispBuiltin * builtin)2852 Lisp_MakeList(LispBuiltin *builtin)
2853 /*
2854 make-list size &key initial-element
2855 */
2856 {
2857 GC_ENTER();
2858 long count;
2859 LispObj *result, *cons;
2860
2861 LispObj *size, *initial_element;
2862
2863 initial_element = ARGUMENT(1);
2864 size = ARGUMENT(0);
2865
2866 CHECK_INDEX(size);
2867 count = FIXNUM_VALUE(size);
2868
2869 if (count == 0)
2870 return (NIL);
2871 if (initial_element == UNSPEC)
2872 initial_element = NIL;
2873
2874 result = cons = CONS(initial_element, NIL);
2875 GC_PROTECT(result);
2876 for (; count > 1; count--) {
2877 RPLACD(cons, CONS(initial_element, NIL));
2878 cons = CDR(cons);
2879 }
2880 GC_LEAVE();
2881
2882 return (result);
2883 }
2884
2885 LispObj *
Lisp_MakeSymbol(LispBuiltin * builtin)2886 Lisp_MakeSymbol(LispBuiltin *builtin)
2887 /*
2888 make-symbol name
2889 */
2890 {
2891 LispObj *name, *symbol;
2892
2893 name = ARGUMENT(0);
2894 CHECK_STRING(name);
2895
2896 symbol = UNINTERNED_ATOM(THESTR(name));
2897 symbol->data.atom->unreadable = !LispCheckAtomString(THESTR(name));
2898
2899 return (symbol);
2900 }
2901
2902 LispObj *
Lisp_Makunbound(LispBuiltin * builtin)2903 Lisp_Makunbound(LispBuiltin *builtin)
2904 /*
2905 makunbound symbol
2906 */
2907 {
2908 LispObj *symbol;
2909
2910 symbol = ARGUMENT(0);
2911
2912 CHECK_SYMBOL(symbol);
2913 LispUnsetVar(symbol);
2914
2915 return (symbol);
2916 }
2917
2918 LispObj *
Lisp_Mapc(LispBuiltin * builtin)2919 Lisp_Mapc(LispBuiltin *builtin)
2920 /*
2921 mapc function list &rest more-lists
2922 */
2923 {
2924 return (LispMapc(builtin, 0));
2925 }
2926
2927 LispObj *
Lisp_Mapcar(LispBuiltin * builtin)2928 Lisp_Mapcar(LispBuiltin *builtin)
2929 /*
2930 mapcar function list &rest more-lists
2931 */
2932 {
2933 return (LispMapc(builtin, 1));
2934 }
2935
2936 /* Like nconc but ignore non list arguments */
2937 LispObj *
LispMapnconc(LispObj * list)2938 LispMapnconc(LispObj *list)
2939 {
2940 LispObj *result = NIL;
2941
2942 if (CONSP(list)) {
2943 LispObj *cons, *head, *tail;
2944
2945 cons = NIL;
2946 for (; CONSP(CDR(list)); list = CDR(list)) {
2947 head = CAR(list);
2948 if (CONSP(head)) {
2949 for (tail = head; CONSP(CDR(tail)); tail = CDR(tail))
2950 ;
2951 if (cons != NIL)
2952 RPLACD(cons, head);
2953 else
2954 result = head;
2955 cons = tail;
2956 }
2957 }
2958 head = CAR(list);
2959 if (CONSP(head)) {
2960 if (cons != NIL)
2961 RPLACD(cons, head);
2962 else
2963 result = head;
2964 }
2965 }
2966
2967 return (result);
2968 }
2969
2970 LispObj *
Lisp_Mapcan(LispBuiltin * builtin)2971 Lisp_Mapcan(LispBuiltin *builtin)
2972 /*
2973 mapcan function list &rest more-lists
2974 */
2975 {
2976 return (LispMapnconc(LispMapc(builtin, 1)));
2977 }
2978
2979 static LispObj *
LispMapc(LispBuiltin * builtin,int mapcar)2980 LispMapc(LispBuiltin *builtin, int mapcar)
2981 {
2982 GC_ENTER();
2983 long i, offset, count, length;
2984 LispObj *result = NIL, *cons, *arguments, *acons, *rest, *alist, *value;
2985 LispObj *stk[8], **cdrs;
2986
2987 LispObj *function, *list, *more_lists;
2988
2989 more_lists = ARGUMENT(2);
2990 list = ARGUMENT(1);
2991 function = ARGUMENT(0);
2992
2993 /* Result will be no longer than this */
2994 for (length = 0, alist = list; CONSP(alist); length++, alist = CDR(alist))
2995 ;
2996
2997 /* If first argument is not a list... */
2998 if (length == 0)
2999 return (NIL);
3000
3001 /* At least one argument will be passed to function, count how many
3002 * extra arguments will be used, and calculate result length. */
3003 count = 0;
3004 for (rest = more_lists; CONSP(rest); rest = CDR(rest), count++) {
3005
3006 /* Check if extra list is really a list, and if it is smaller
3007 * than the first list */
3008 for (i = 0, alist = CAR(rest);
3009 i < length && CONSP(alist);
3010 i++, alist = CDR(alist))
3011 ;
3012
3013 /* If it is not a true list */
3014 if (i == 0)
3015 return (NIL);
3016
3017 /* If it is smaller than the currently calculated result length */
3018 if (i < length)
3019 length = i;
3020 }
3021
3022 if (mapcar) {
3023 /* Initialize gc protected object cells for resulting list */
3024 result = cons = CONS(NIL, NIL);
3025 GC_PROTECT(result);
3026 }
3027 else
3028 result = cons = list;
3029
3030 if (count >= sizeof(stk) / sizeof(stk[0]))
3031 cdrs = LispMalloc(count * sizeof(LispObj*));
3032 else
3033 cdrs = &stk[0];
3034 for (i = 0, rest = more_lists; i < count; i++, rest = CDR(rest))
3035 cdrs[i] = CAR(rest);
3036
3037 /* Initialize gc protected object cells for argument list */
3038 arguments = acons = CONS(NIL, NIL);
3039 GC_PROTECT(arguments);
3040
3041 /* Allocate space for extra arguments */
3042 for (i = 0; i < count; i++) {
3043 RPLACD(acons, CONS(NIL, NIL));
3044 acons = CDR(acons);
3045 }
3046
3047 /* For every element of the list that will be used */
3048 for (offset = 0;; list = CDR(list)) {
3049 acons = arguments;
3050
3051 /* Add first argument */
3052 RPLACA(acons, CAR(list));
3053 acons = CDR(acons);
3054
3055 /* For every extra list argument */
3056 for (i = 0; i < count; i++) {
3057 alist = cdrs[i];
3058 cdrs[i] = CDR(cdrs[i]);
3059
3060 /* Add element to argument list */
3061 RPLACA(acons, CAR(alist));
3062 acons = CDR(acons);
3063 }
3064
3065 value = APPLY(function, arguments);
3066
3067 if (mapcar) {
3068 /* Store result */
3069 RPLACA(cons, value);
3070
3071 /* Allocate new result cell */
3072 if (++offset < length) {
3073 RPLACD(cons, CONS(NIL, NIL));
3074 cons = CDR(cons);
3075 }
3076 else
3077 break;
3078 }
3079 else if (++offset >= length)
3080 break;
3081 }
3082
3083 /* Unprotect argument and result list */
3084 GC_LEAVE();
3085 if (cdrs != &stk[0])
3086 LispFree(cdrs);
3087
3088 return (result);
3089 }
3090
3091 static LispObj *
LispMapl(LispBuiltin * builtin,int maplist)3092 LispMapl(LispBuiltin *builtin, int maplist)
3093 {
3094 GC_ENTER();
3095 long i, offset, count, length;
3096 LispObj *result = NIL, *cons, *arguments, *acons, *rest, *alist, *value;
3097 LispObj *stk[8], **cdrs;
3098
3099 LispObj *function, *list, *more_lists;
3100
3101 more_lists = ARGUMENT(2);
3102 list = ARGUMENT(1);
3103 function = ARGUMENT(0);
3104
3105 /* count is the number of lists, length is the length of the result */
3106 for (length = 0, alist = list; CONSP(alist); length++, alist = CDR(alist))
3107 ;
3108
3109 /* first argument is not a list */
3110 if (length == 0)
3111 return (NIL);
3112
3113 /* check remaining arguments */
3114 for (count = 0, rest = more_lists; CONSP(rest); rest = CDR(rest), count++) {
3115 for (i = 0, alist = CAR(rest);
3116 i < length && CONSP(alist);
3117 i++, alist = CDR(alist))
3118 ;
3119 /* argument is not a list */
3120 if (i == 0)
3121 return (NIL);
3122 /* result will have the length of the smallest list */
3123 if (i < length)
3124 length = i;
3125 }
3126
3127 /* result will be a list */
3128 if (maplist) {
3129 result = cons = CONS(NIL, NIL);
3130 GC_PROTECT(result);
3131 }
3132 else
3133 result = cons = list;
3134
3135 if (count >= sizeof(stk) / sizeof(stk[0]))
3136 cdrs = LispMalloc(count * sizeof(LispObj*));
3137 else
3138 cdrs = &stk[0];
3139 for (i = 0, rest = more_lists; i < count; i++, rest = CDR(rest))
3140 cdrs[i] = CAR(rest);
3141
3142 /* initialize argument list */
3143 arguments = acons = CONS(NIL, NIL);
3144 GC_PROTECT(arguments);
3145 for (i = 0; i < count; i++) {
3146 RPLACD(acons, CONS(NIL, NIL));
3147 acons = CDR(acons);
3148 }
3149
3150 /* for every used list element */
3151 for (offset = 0;; list = CDR(list)) {
3152 acons = arguments;
3153
3154 /* first argument */
3155 RPLACA(acons, list);
3156 acons = CDR(acons);
3157
3158 /* for every extra list */
3159 for (i = 0; i < count; i++) {
3160 RPLACA(acons, cdrs[i]);
3161 cdrs[i] = CDR(cdrs[i]);
3162 acons = CDR(acons);
3163 }
3164
3165 value = APPLY(function, arguments);
3166
3167 if (maplist) {
3168 /* store result */
3169 RPLACA(cons, value);
3170
3171 /* allocate new cell */
3172 if (++offset < length) {
3173 RPLACD(cons, CONS(NIL, NIL));
3174 cons = CDR(cons);
3175 }
3176 else
3177 break;
3178 }
3179 else if (++offset >= length)
3180 break;
3181 }
3182
3183 GC_LEAVE();
3184 if (cdrs != &stk[0])
3185 LispFree(cdrs);
3186
3187 return (result);
3188 }
3189
3190 LispObj *
Lisp_Mapl(LispBuiltin * builtin)3191 Lisp_Mapl(LispBuiltin *builtin)
3192 /*
3193 mapl function list &rest more-lists
3194 */
3195 {
3196 return (LispMapl(builtin, 0));
3197 }
3198
3199 LispObj *
Lisp_Maplist(LispBuiltin * builtin)3200 Lisp_Maplist(LispBuiltin *builtin)
3201 /*
3202 maplist function list &rest more-lists
3203 */
3204 {
3205 return (LispMapl(builtin, 1));
3206 }
3207
3208 LispObj *
Lisp_Mapcon(LispBuiltin * builtin)3209 Lisp_Mapcon(LispBuiltin *builtin)
3210 /*
3211 mapcon function list &rest more-lists
3212 */
3213 {
3214 return (LispMapnconc(LispMapl(builtin, 1)));
3215 }
3216
3217 LispObj *
Lisp_Member(LispBuiltin * builtin)3218 Lisp_Member(LispBuiltin *builtin)
3219 /*
3220 member item list &key test test-not key
3221 */
3222 {
3223 int code, expect;
3224 LispObj *compare, *lambda;
3225 LispObj *item, *list, *test, *test_not, *key;
3226
3227 key = ARGUMENT(4);
3228 test_not = ARGUMENT(3);
3229 test = ARGUMENT(2);
3230 list = ARGUMENT(1);
3231 item = ARGUMENT(0);
3232
3233 if (list == NIL)
3234 return (NIL);
3235 CHECK_CONS(list);
3236
3237 CHECK_TEST();
3238 if (key == UNSPEC) {
3239 if (code == FEQ) {
3240 for (; CONSP(list); list = CDR(list))
3241 if (item == CAR(list))
3242 return (list);
3243 }
3244 else {
3245 for (; CONSP(list); list = CDR(list))
3246 if ((FCOMPARE(lambda, item, CAR(list), code)) == expect)
3247 return (list);
3248 }
3249 }
3250 else {
3251 if (code == FEQ) {
3252 for (; CONSP(list); list = CDR(list))
3253 if (item == APPLY1(key, CAR(list)))
3254 return (list);
3255 }
3256 else {
3257 for (; CONSP(list); list = CDR(list)) {
3258 compare = APPLY1(key, CAR(list));
3259 if ((FCOMPARE(lambda, item, compare, code)) == expect)
3260 return (list);
3261 }
3262 }
3263 }
3264 /* check if is a proper list */
3265 CHECK_LIST(list);
3266
3267 return (NIL);
3268 }
3269
3270 LispObj *
Lisp_MemberIf(LispBuiltin * builtin)3271 Lisp_MemberIf(LispBuiltin *builtin)
3272 /*
3273 member-if predicate list &key key
3274 */
3275 {
3276 return (LispAssocOrMember(builtin, MEMBER, IF));
3277 }
3278
3279 LispObj *
Lisp_MemberIfNot(LispBuiltin * builtin)3280 Lisp_MemberIfNot(LispBuiltin *builtin)
3281 /*
3282 member-if-not predicate list &key key
3283 */
3284 {
3285 return (LispAssocOrMember(builtin, MEMBER, IFNOT));
3286 }
3287
3288 LispObj *
Lisp_MultipleValueBind(LispBuiltin * builtin)3289 Lisp_MultipleValueBind(LispBuiltin *builtin)
3290 /*
3291 multiple-value-bind symbols values &rest body
3292 */
3293 {
3294 int i, head = lisp__data.env.length;
3295 LispObj *result, *symbol, *value;
3296
3297 LispObj *symbols, *values, *body;
3298
3299 body = ARGUMENT(2);
3300 values = ARGUMENT(1);
3301 symbols = ARGUMENT(0);
3302
3303 result = EVAL(values);
3304 for (i = -1; CONSP(symbols); symbols = CDR(symbols), i++) {
3305 symbol = CAR(symbols);
3306 CHECK_SYMBOL(symbol);
3307 CHECK_CONSTANT(symbol);
3308 if (i >= 0 && i < RETURN_COUNT)
3309 value = RETURN(i);
3310 else if (i < 0)
3311 value = result;
3312 else
3313 value = NIL;
3314 LispAddVar(symbol, value);
3315 ++lisp__data.env.head;
3316 }
3317
3318 /* Execute code with binded variables (if any) */
3319 for (result = NIL; CONSP(body); body = CDR(body))
3320 result = EVAL(CAR(body));
3321
3322 lisp__data.env.head = lisp__data.env.length = head;
3323
3324 return (result);
3325 }
3326
3327 LispObj *
Lisp_MultipleValueCall(LispBuiltin * builtin)3328 Lisp_MultipleValueCall(LispBuiltin *builtin)
3329 /*
3330 multiple-value-call function &rest form
3331 */
3332 {
3333 GC_ENTER();
3334 int i;
3335 LispObj *arguments, *cons, *result;
3336
3337 LispObj *function, *form;
3338
3339 form = ARGUMENT(1);
3340 function = ARGUMENT(0);
3341
3342 /* build argument list */
3343 arguments = cons = NIL;
3344 for (; CONSP(form); form = CDR(form)) {
3345 RETURN_COUNT = 0;
3346 result = EVAL(CAR(form));
3347 if (RETURN_COUNT >= 0) {
3348 if (arguments == NIL) {
3349 arguments = cons = CONS(result, NIL);
3350 GC_PROTECT(arguments);
3351 }
3352 else {
3353 RPLACD(cons, CONS(result, NIL));
3354 cons = CDR(cons);
3355 }
3356 for (i = 0; i < RETURN_COUNT; i++) {
3357 RPLACD(cons, CONS(RETURN(i), NIL));
3358 cons = CDR(cons);
3359 }
3360 }
3361 }
3362
3363 /* apply function */
3364 if (POINTERP(function) && !XSYMBOLP(function) && !XFUNCTIONP(function)) {
3365 function = EVAL(function);
3366 GC_PROTECT(function);
3367 }
3368 result = APPLY(function, arguments);
3369 GC_LEAVE();
3370
3371 return (result);
3372 }
3373
3374 LispObj *
Lisp_MultipleValueProg1(LispBuiltin * builtin)3375 Lisp_MultipleValueProg1(LispBuiltin *builtin)
3376 /*
3377 multiple-value-prog1 first-form &rest form
3378 */
3379 {
3380 GC_ENTER();
3381 int i, count;
3382 LispObj *values, *cons;
3383
3384 LispObj *first_form, *form;
3385
3386 form = ARGUMENT(1);
3387 first_form = ARGUMENT(0);
3388
3389 values = EVAL(first_form);
3390 if (!CONSP(form))
3391 return (values);
3392
3393 cons = NIL;
3394 count = RETURN_COUNT;
3395 if (count < 0)
3396 values = NIL;
3397 else if (count == 0) {
3398 GC_PROTECT(values);
3399 }
3400 else {
3401 values = cons = CONS(values, NIL);
3402 GC_PROTECT(values);
3403 for (i = 0; i < count; i++) {
3404 RPLACD(cons, CONS(RETURN(i), NIL));
3405 cons = CDR(cons);
3406 }
3407 }
3408
3409 for (; CONSP(form); form = CDR(form))
3410 EVAL(CAR(form));
3411
3412 RETURN_COUNT = count;
3413 if (count > 0) {
3414 for (i = 0, cons = CDR(values); CONSP(cons); cons = CDR(cons), i++)
3415 RETURN(i) = CAR(cons);
3416 values = CAR(values);
3417 }
3418 GC_LEAVE();
3419
3420 return (values);
3421 }
3422
3423 LispObj *
Lisp_MultipleValueList(LispBuiltin * builtin)3424 Lisp_MultipleValueList(LispBuiltin *builtin)
3425 /*
3426 multiple-value-list form
3427 */
3428 {
3429 int i;
3430 GC_ENTER();
3431 LispObj *form, *result, *cons;
3432
3433 form = ARGUMENT(0);
3434
3435 result = EVAL(form);
3436
3437 if (RETURN_COUNT < 0)
3438 return (NIL);
3439
3440 result = cons = CONS(result, NIL);
3441 GC_PROTECT(result);
3442 for (i = 0; i < RETURN_COUNT; i++) {
3443 RPLACD(cons, CONS(RETURN(i), NIL));
3444 cons = CDR(cons);
3445 }
3446 GC_LEAVE();
3447
3448 return (result);
3449 }
3450
3451 LispObj *
Lisp_MultipleValueSetq(LispBuiltin * builtin)3452 Lisp_MultipleValueSetq(LispBuiltin *builtin)
3453 /*
3454 multiple-value-setq symbols form
3455 */
3456 {
3457 int i;
3458 LispObj *result, *symbol, *value;
3459
3460 LispObj *symbols, *form;
3461
3462 form = ARGUMENT(1);
3463 symbols = ARGUMENT(0);
3464
3465 CHECK_LIST(symbols);
3466 result = EVAL(form);
3467 if (CONSP(symbols)) {
3468 symbol = CAR(symbols);
3469 CHECK_SYMBOL(symbol);
3470 CHECK_CONSTANT(symbol);
3471 LispSetVar(symbol, result);
3472 symbols = CDR(symbols);
3473 }
3474 for (i = 0; CONSP(symbols); symbols = CDR(symbols), i++) {
3475 symbol = CAR(symbols);
3476 CHECK_SYMBOL(symbol);
3477 CHECK_CONSTANT(symbol);
3478 if (i < RETURN_COUNT && RETURN_COUNT > 0)
3479 value = RETURN(i);
3480 else
3481 value = NIL;
3482 LispSetVar(symbol, value);
3483 }
3484
3485 return (result);
3486 }
3487
3488 LispObj *
Lisp_Nconc(LispBuiltin * builtin)3489 Lisp_Nconc(LispBuiltin *builtin)
3490 /*
3491 nconc &rest lists
3492 */
3493 {
3494 LispObj *list, *lists, *cons, *head, *tail;
3495
3496 lists = ARGUMENT(0);
3497
3498 /* skip any initial empty lists */
3499 for (; CONSP(lists); lists = CDR(lists))
3500 if (CAR(lists) != NIL)
3501 break;
3502
3503 /* don't check if a proper list */
3504 if (!CONSP(lists))
3505 return (lists);
3506
3507 /* setup to concatenate lists */
3508 list = CAR(lists);
3509 CHECK_CONS(list);
3510 for (cons = list; CONSP(CDR(cons)); cons = CDR(cons))
3511 ;
3512
3513 /* if only two lists */
3514 lists = CDR(lists);
3515 if (!CONSP(lists)) {
3516 RPLACD(cons, lists);
3517
3518 return (list);
3519 }
3520
3521 /* concatenate */
3522 for (; CONSP(CDR(lists)); lists = CDR(lists)) {
3523 head = CAR(lists);
3524 if (head == NIL)
3525 continue;
3526 CHECK_CONS(head);
3527 for (tail = head; CONSP(CDR(tail)); tail = CDR(tail))
3528 ;
3529 RPLACD(cons, head);
3530 cons = tail;
3531 }
3532 /* add last list */
3533 RPLACD(cons, CAR(lists));
3534
3535 return (list);
3536 }
3537
3538 LispObj *
Lisp_Nreverse(LispBuiltin * builtin)3539 Lisp_Nreverse(LispBuiltin *builtin)
3540 /*
3541 nreverse sequence
3542 */
3543 {
3544 return (LispXReverse(builtin, 1));
3545 }
3546
3547 LispObj *
Lisp_NsetDifference(LispBuiltin * builtin)3548 Lisp_NsetDifference(LispBuiltin *builtin)
3549 /*
3550 nset-difference list1 list2 &key test test-not key
3551 */
3552 {
3553 return (LispListSet(builtin, NSETDIFFERENCE));
3554 }
3555
3556 LispObj *
Lisp_Nsubstitute(LispBuiltin * builtin)3557 Lisp_Nsubstitute(LispBuiltin *builtin)
3558 /*
3559 nsubstitute newitem olditem sequence &key from-end test test-not start end count key
3560 */
3561 {
3562 return (LispDeleteRemoveXSubstitute(builtin, NSUBSTITUTE, NONE));
3563 }
3564
3565 LispObj *
Lisp_NsubstituteIf(LispBuiltin * builtin)3566 Lisp_NsubstituteIf(LispBuiltin *builtin)
3567 /*
3568 nsubstitute-if newitem test sequence &key from-end start end count key
3569 */
3570 {
3571 return (LispDeleteRemoveXSubstitute(builtin, NSUBSTITUTE, IF));
3572 }
3573
3574 LispObj *
Lisp_NsubstituteIfNot(LispBuiltin * builtin)3575 Lisp_NsubstituteIfNot(LispBuiltin *builtin)
3576 /*
3577 nsubstitute-if-not newitem test sequence &key from-end start end count key
3578 */
3579 {
3580 return (LispDeleteRemoveXSubstitute(builtin, NSUBSTITUTE, IFNOT));
3581 }
3582
3583 LispObj *
Lisp_Nth(LispBuiltin * builtin)3584 Lisp_Nth(LispBuiltin *builtin)
3585 /*
3586 nth index list
3587 */
3588 {
3589 long position;
3590 LispObj *oindex, *list;
3591
3592 list = ARGUMENT(1);
3593 oindex = ARGUMENT(0);
3594
3595 CHECK_INDEX(oindex);
3596 position = FIXNUM_VALUE(oindex);
3597
3598 if (list == NIL)
3599 return (NIL);
3600
3601 CHECK_CONS(list);
3602 for (; position > 0; position--) {
3603 if (!CONSP(list))
3604 return (NIL);
3605 list = CDR(list);
3606 }
3607
3608 return (CONSP(list) ? CAR(list) : NIL);
3609 }
3610
3611 LispObj *
Lisp_Nthcdr(LispBuiltin * builtin)3612 Lisp_Nthcdr(LispBuiltin *builtin)
3613 /*
3614 nthcdr index list
3615 */
3616 {
3617 long position;
3618 LispObj *oindex, *list;
3619
3620 list = ARGUMENT(1);
3621 oindex = ARGUMENT(0);
3622
3623 CHECK_INDEX(oindex);
3624 position = FIXNUM_VALUE(oindex);
3625
3626 if (list == NIL)
3627 return (NIL);
3628 CHECK_CONS(list);
3629
3630 for (; position > 0; position--) {
3631 if (!CONSP(list))
3632 return (NIL);
3633 list = CDR(list);
3634 }
3635
3636 return (list);
3637 }
3638
3639 LispObj *
Lisp_NthValue(LispBuiltin * builtin)3640 Lisp_NthValue(LispBuiltin *builtin)
3641 /*
3642 nth-value index form
3643 */
3644 {
3645 long i;
3646 LispObj *oindex, *form, *result;
3647
3648 form = ARGUMENT(1);
3649 oindex = ARGUMENT(0);
3650
3651 oindex = EVAL(oindex);
3652 CHECK_INDEX(oindex);
3653 i = FIXNUM_VALUE(oindex) - 1;
3654
3655 result = EVAL(form);
3656 if (RETURN_COUNT < 0 || i >= RETURN_COUNT)
3657 result = NIL;
3658 else if (i >= 0)
3659 result = RETURN(i);
3660
3661 return (result);
3662 }
3663
3664 LispObj *
Lisp_Null(LispBuiltin * builtin)3665 Lisp_Null(LispBuiltin *builtin)
3666 /*
3667 null list
3668 */
3669 {
3670 LispObj *list;
3671
3672 list = ARGUMENT(0);
3673
3674 return (list == NIL ? T : NIL);
3675 }
3676
3677 LispObj *
Lisp_Or(LispBuiltin * builtin)3678 Lisp_Or(LispBuiltin *builtin)
3679 /*
3680 or &rest args
3681 */
3682 {
3683 LispObj *result = NIL, *args;
3684
3685 args = ARGUMENT(0);
3686
3687 for (; CONSP(args); args = CDR(args)) {
3688 result = EVAL(CAR(args));
3689 if (result != NIL)
3690 break;
3691 }
3692
3693 return (result);
3694 }
3695
3696 LispObj *
Lisp_Pairlis(LispBuiltin * builtin)3697 Lisp_Pairlis(LispBuiltin *builtin)
3698 /*
3699 pairlis key data &optional alist
3700 */
3701 {
3702 LispObj *result, *cons;
3703
3704 LispObj *key, *data, *alist;
3705
3706 alist = ARGUMENT(2);
3707 data = ARGUMENT(1);
3708 key = ARGUMENT(0);
3709
3710 if (CONSP(key) && CONSP(data)) {
3711 GC_ENTER();
3712
3713 result = cons = CONS(CONS(CAR(key), CAR(data)), NIL);
3714 GC_PROTECT(result);
3715 key = CDR(key);
3716 data = CDR(data);
3717 for (; CONSP(key) && CONSP(data); key = CDR(key), data = CDR(data)) {
3718 RPLACD(cons, CONS(CONS(CAR(key), CAR(data)), NIL));
3719 cons = CDR(cons);
3720 }
3721 if (CONSP(key) || CONSP(data))
3722 LispDestroy("%s: different length lists", STRFUN(builtin));
3723 GC_LEAVE();
3724 if (alist != UNSPEC)
3725 RPLACD(cons, alist);
3726 }
3727 else
3728 result = alist == UNSPEC ? NIL : alist;
3729
3730 return (result);
3731 }
3732
3733 static LispObj *
LispFindOrPosition(LispBuiltin * builtin,int function,int comparison)3734 LispFindOrPosition(LispBuiltin *builtin,
3735 int function, int comparison)
3736 /*
3737 find item sequence &key from-end test test-not start end key
3738 find-if predicate sequence &key from-end start end key
3739 find-if-not predicate sequence &key from-end start end key
3740 position item sequence &key from-end test test-not start end key
3741 position-if predicate sequence &key from-end start end key
3742 position-if-not predicate sequence &key from-end start end key
3743 */
3744 {
3745 int code = 0, istring, expect, value;
3746 char *string = NULL;
3747 long offset = -1, start, end, length, i = comparison == NONE ? 7 : 5;
3748 LispObj *cmp, *element, **objects = NULL;
3749
3750 LispObj *item, *predicate, *sequence, *from_end,
3751 *test, *test_not, *ostart, *oend, *key;
3752
3753 key = ARGUMENT(i); --i;
3754 oend = ARGUMENT(i); --i;
3755 ostart = ARGUMENT(i); --i;
3756 if (comparison == NONE) {
3757 test_not = ARGUMENT(i); --i;
3758 test = ARGUMENT(i); --i;
3759 }
3760 else
3761 test_not = test = UNSPEC;
3762 from_end = ARGUMENT(i); --i;
3763 if (from_end == UNSPEC)
3764 from_end = NIL;
3765 sequence = ARGUMENT(i); --i;
3766 if (comparison == NONE) {
3767 item = ARGUMENT(i);
3768 predicate = Oeql;
3769 }
3770 else {
3771 predicate = ARGUMENT(i);
3772 item = NIL;
3773 }
3774
3775 LispCheckSequenceStartEnd(builtin, sequence, ostart, oend,
3776 &start, &end, &length);
3777
3778 if (sequence == NIL)
3779 return (NIL);
3780
3781 /* Cannot specify both :test and :test-not */
3782 if (test != UNSPEC && test_not != UNSPEC)
3783 LispDestroy("%s: specify either :TEST or :TEST-NOT", STRFUN(builtin));
3784
3785 expect = 1;
3786 if (comparison == NONE) {
3787 if (test != UNSPEC)
3788 predicate = test;
3789 else if (test_not != UNSPEC) {
3790 predicate = test_not;
3791 expect = 0;
3792 }
3793 FUNCTION_CHECK(predicate);
3794 code = FCODE(predicate);
3795 }
3796
3797 cmp = element = NIL;
3798 istring = STRINGP(sequence);
3799 if (istring)
3800 string = THESTR(sequence);
3801 else {
3802 if (!CONSP(sequence))
3803 sequence = sequence->data.array.list;
3804 for (i = 0; i < start; i++)
3805 sequence = CDR(sequence);
3806 }
3807
3808 if ((length = end - start) == 0)
3809 return (NIL);
3810
3811 if (from_end != NIL && !istring) {
3812 objects = LispMalloc(sizeof(LispObj*) * length);
3813 for (i = length - 1; i >= 0; i--, sequence = CDR(sequence))
3814 objects[i] = CAR(sequence);
3815 }
3816
3817 for (i = 0; i < length; i++) {
3818 if (istring)
3819 element = SCHAR(string[from_end == NIL ? i + start : end - i - 1]);
3820 else
3821 element = from_end == NIL ? CAR(sequence) : objects[i];
3822
3823 if (key != UNSPEC)
3824 cmp = APPLY1(key, element);
3825 else
3826 cmp = element;
3827
3828 /* Update list */
3829 if (!istring && from_end == NIL)
3830 sequence = CDR(sequence);
3831
3832 if (comparison == NONE)
3833 value = FCOMPARE(predicate, item, cmp, code);
3834 else
3835 value = APPLY1(predicate, cmp) != NIL;
3836
3837 if ((!value &&
3838 (comparison == IFNOT ||
3839 (comparison == NONE && !expect))) ||
3840 (value &&
3841 (comparison == IF ||
3842 (comparison == NONE && expect)))) {
3843 offset = from_end == NIL ? i + start : end - i - 1;
3844 break;
3845 }
3846 }
3847
3848 if (from_end != NIL && !istring)
3849 LispFree(objects);
3850
3851 return (offset == -1 ? NIL : function == FIND ? element : FIXNUM(offset));
3852 }
3853
3854 LispObj *
Lisp_Pop(LispBuiltin * builtin)3855 Lisp_Pop(LispBuiltin *builtin)
3856 /*
3857 pop place
3858 */
3859 {
3860 LispObj *result, *value;
3861
3862 LispObj *place;
3863
3864 place = ARGUMENT(0);
3865
3866 if (SYMBOLP(place)) {
3867 result = LispGetVar(place);
3868 if (result == NULL)
3869 LispDestroy("EVAL: the variable %s is unbound", STROBJ(place));
3870 CHECK_CONSTANT(place);
3871 if (result != NIL) {
3872 CHECK_CONS(result);
3873 value = CDR(result);
3874 result = CAR(result);
3875 }
3876 else
3877 value = NIL;
3878 LispSetVar(place, value);
3879 }
3880 else {
3881 GC_ENTER();
3882 LispObj quote;
3883
3884 result = EVAL(place);
3885 if (result != NIL) {
3886 CHECK_CONS(result);
3887 value = CDR(result);
3888 GC_PROTECT(value);
3889 result = CAR(result);
3890 }
3891 else
3892 value = NIL;
3893 quote.type = LispQuote_t;
3894 quote.data.quote = value;
3895 APPLY2(Osetf, place, "e);
3896 GC_LEAVE();
3897 }
3898
3899 return (result);
3900 }
3901
3902 LispObj *
Lisp_Position(LispBuiltin * builtin)3903 Lisp_Position(LispBuiltin *builtin)
3904 /*
3905 position item sequence &key from-end test test-not start end key
3906 */
3907 {
3908 return (LispFindOrPosition(builtin, POSITION, NONE));
3909 }
3910
3911 LispObj *
Lisp_PositionIf(LispBuiltin * builtin)3912 Lisp_PositionIf(LispBuiltin *builtin)
3913 /*
3914 position-if predicate sequence &key from-end start end key
3915 */
3916 {
3917 return (LispFindOrPosition(builtin, POSITION, IF));
3918 }
3919
3920 LispObj *
Lisp_PositionIfNot(LispBuiltin * builtin)3921 Lisp_PositionIfNot(LispBuiltin *builtin)
3922 /*
3923 position-if-not predicate sequence &key from-end start end key
3924 */
3925 {
3926 return (LispFindOrPosition(builtin, POSITION, IFNOT));
3927 }
3928
3929 LispObj *
Lisp_Proclaim(LispBuiltin * builtin)3930 Lisp_Proclaim(LispBuiltin *builtin)
3931 /*
3932 proclaim declaration
3933 */
3934 {
3935 LispObj *arguments, *object;
3936 char *operation;
3937
3938 LispObj *declaration;
3939
3940 declaration = ARGUMENT(0);
3941
3942 CHECK_CONS(declaration);
3943
3944 arguments = declaration;
3945 object = CAR(arguments);
3946 CHECK_SYMBOL(object);
3947
3948 operation = ATOMID(object)->value;
3949 if (strcmp(operation, "SPECIAL") == 0) {
3950 for (arguments = CDR(arguments); CONSP(arguments);
3951 arguments = CDR(arguments)) {
3952 object = CAR(arguments);
3953 CHECK_SYMBOL(object);
3954 LispProclaimSpecial(object, NULL, NIL);
3955 }
3956 }
3957 else if (strcmp(operation, "TYPE") == 0) {
3958 /* XXX no type checking yet, but should be added */
3959 }
3960 /* else do nothing */
3961
3962 return (NIL);
3963 }
3964
3965 LispObj *
Lisp_Prog1(LispBuiltin * builtin)3966 Lisp_Prog1(LispBuiltin *builtin)
3967 /*
3968 prog1 first &rest body
3969 */
3970 {
3971 GC_ENTER();
3972 LispObj *result;
3973
3974 LispObj *first, *body;
3975
3976 body = ARGUMENT(1);
3977 first = ARGUMENT(0);
3978
3979 result = EVAL(first);
3980
3981 GC_PROTECT(result);
3982 for (; CONSP(body); body = CDR(body))
3983 (void)EVAL(CAR(body));
3984 GC_LEAVE();
3985
3986 return (result);
3987 }
3988
3989 LispObj *
Lisp_Prog2(LispBuiltin * builtin)3990 Lisp_Prog2(LispBuiltin *builtin)
3991 /*
3992 prog2 first second &rest body
3993 */
3994 {
3995 GC_ENTER();
3996 LispObj *result;
3997
3998 LispObj *first, *second, *body;
3999
4000 body = ARGUMENT(2);
4001 second = ARGUMENT(1);
4002 first = ARGUMENT(0);
4003
4004 (void)EVAL(first);
4005 result = EVAL(second);
4006 GC_PROTECT(result);
4007 for (; CONSP(body); body = CDR(body))
4008 (void)EVAL(CAR(body));
4009 GC_LEAVE();
4010
4011 return (result);
4012 }
4013
4014 LispObj *
Lisp_Progn(LispBuiltin * builtin)4015 Lisp_Progn(LispBuiltin *builtin)
4016 /*
4017 progn &rest body
4018 */
4019 {
4020 LispObj *result = NIL;
4021
4022 LispObj *body;
4023
4024 body = ARGUMENT(0);
4025
4026 for (; CONSP(body); body = CDR(body))
4027 result = EVAL(CAR(body));
4028
4029 return (result);
4030 }
4031
4032 /*
4033 * This does what I believe is the expected behaviour (or at least
4034 * acceptable for the the interpreter), if the code being executed
4035 * ever tries to change/bind a progv symbol, the symbol state will
4036 * be restored when exiting the progv block, so, code like:
4037 * (progv '(*x*) '(1) (defvar *x* 10))
4038 * when exiting the block, will have *x* unbound, and not a dynamic
4039 * symbol; if it was already bound, will have the old value.
4040 * Symbols already dynamic can be freely changed, even unbounded in
4041 * the progv block.
4042 */
4043 LispObj *
Lisp_Progv(LispBuiltin * builtin)4044 Lisp_Progv(LispBuiltin *builtin)
4045 /*
4046 progv symbols values &rest body
4047 */
4048 {
4049 GC_ENTER();
4050 int head = lisp__data.env.length, i, count, ostk[32], *offsets;
4051 LispObj *result, *list, *symbol, *value;
4052 int jumped;
4053 char fstk[32], *flags;
4054 LispBlock *block;
4055 LispAtom *atom;
4056
4057 LispObj *symbols, *values, *body;
4058
4059 /* Possible states */
4060 #define DYNAMIC_SYMBOL 1
4061 #define GLOBAL_SYMBOL 2
4062 #define UNBOUND_SYMBOL 3
4063
4064 body = ARGUMENT(2);
4065 values = ARGUMENT(1);
4066 symbols = ARGUMENT(0);
4067
4068 /* get symbol names */
4069 symbols = EVAL(symbols);
4070 GC_PROTECT(symbols);
4071
4072 /* get symbol values */
4073 values = EVAL(values);
4074 GC_PROTECT(values);
4075
4076 /* count/check symbols and allocate space to remember symbol state */
4077 for (count = 0, list = symbols; CONSP(list); count++, list = CDR(list)) {
4078 symbol = CAR(list);
4079 CHECK_SYMBOL(symbol);
4080 CHECK_CONSTANT(symbol);
4081 }
4082 if (count > sizeof(fstk)) {
4083 flags = LispMalloc(count);
4084 offsets = LispMalloc(count * sizeof(int));
4085 }
4086 else {
4087 flags = &fstk[0];
4088 offsets = &ostk[0];
4089 }
4090
4091 /* store flags and save old value if required */
4092 for (i = 0, list = symbols; i < count; i++, list = CDR(list)) {
4093 atom = CAR(list)->data.atom;
4094 if (atom->dyn)
4095 flags[i] = DYNAMIC_SYMBOL;
4096 else if (atom->a_object) {
4097 flags[i] = GLOBAL_SYMBOL;
4098 offsets[i] = lisp__data.protect.length;
4099 GC_PROTECT(atom->property->value);
4100 }
4101 else
4102 flags[i] = UNBOUND_SYMBOL;
4103 }
4104
4105 /* bind the symbols */
4106 for (i = 0, list = symbols; i < count; i++, list = CDR(list)) {
4107 symbol = CAR(list);
4108 atom = symbol->data.atom;
4109 if (CONSP(values)) {
4110 value = CAR(values);
4111 values = CDR(values);
4112 }
4113 else
4114 value = NIL;
4115 if (flags[i] != DYNAMIC_SYMBOL) {
4116 if (!atom->a_object)
4117 LispSetAtomObjectProperty(atom, value);
4118 else
4119 SETVALUE(atom, value);
4120 }
4121 else
4122 LispAddVar(symbol, value);
4123 }
4124 /* bind dynamic symbols */
4125 lisp__data.env.head = lisp__data.env.length;
4126
4127 jumped = 0;
4128 result = NIL;
4129 block = LispBeginBlock(NIL, LispBlockProtect);
4130 if (setjmp(block->jmp) == 0) {
4131 for (; CONSP(body); body = CDR(body))
4132 result = EVAL(CAR(body));
4133 }
4134
4135 /* restore symbols */
4136 for (i = 0, list = symbols; i < count; i++, list = CDR(list)) {
4137 symbol = CAR(list);
4138 atom = symbol->data.atom;
4139 if (flags[i] != DYNAMIC_SYMBOL) {
4140 if (flags[i] == UNBOUND_SYMBOL)
4141 LispUnsetVar(symbol);
4142 else {
4143 /* restore global symbol value */
4144 LispSetAtomObjectProperty(atom, lisp__data.protect.objects
4145 [offsets[i]]);
4146 atom->dyn = 0;
4147 }
4148 }
4149 }
4150 /* unbind dynamic symbols */
4151 lisp__data.env.head = lisp__data.env.length = head;
4152 GC_LEAVE();
4153
4154 if (count > sizeof(fstk)) {
4155 LispFree(flags);
4156 LispFree(offsets);
4157 }
4158
4159 LispEndBlock(block);
4160 if (!lisp__data.destroyed) {
4161 if (jumped)
4162 result = lisp__data.block.block_ret;
4163 }
4164 else {
4165 /* check if there is an unwind-protect block */
4166 LispBlockUnwind(NULL);
4167
4168 /* no unwind-protect block, return to the toplevel */
4169 LispDestroy(".");
4170 }
4171
4172 return (result);
4173 }
4174
4175 LispObj *
Lisp_Provide(LispBuiltin * builtin)4176 Lisp_Provide(LispBuiltin *builtin)
4177 /*
4178 provide module
4179 */
4180 {
4181 LispObj *module, *obj;
4182
4183 module = ARGUMENT(0);
4184
4185 CHECK_STRING(module);
4186 for (obj = MOD; obj != NIL; obj = CDR(obj)) {
4187 if (STRLEN(CAR(obj)) == STRLEN(module) &&
4188 memcmp(THESTR(CAR(obj)), THESTR(module), STRLEN(module)) == 0)
4189 return (module);
4190 }
4191
4192 if (MOD == NIL)
4193 MOD = CONS(module, NIL);
4194 else {
4195 RPLACD(MOD, CONS(CAR(MOD), CDR(MOD)));
4196 RPLACA(MOD, module);
4197 }
4198
4199 LispSetVar(lisp__data.modules, MOD);
4200
4201 return (MOD);
4202 }
4203
4204 LispObj *
Lisp_Push(LispBuiltin * builtin)4205 Lisp_Push(LispBuiltin *builtin)
4206 /*
4207 push item place
4208 */
4209 {
4210 LispObj *result, *list;
4211
4212 LispObj *item, *place;
4213
4214 place = ARGUMENT(1);
4215 item = ARGUMENT(0);
4216
4217 item = EVAL(item);
4218
4219 if (SYMBOLP(place)) {
4220 list = LispGetVar(place);
4221 if (list == NULL)
4222 LispDestroy("EVAL: the variable %s is unbound", STROBJ(place));
4223 CHECK_CONSTANT(place);
4224 LispSetVar(place, result = CONS(item, list));
4225 }
4226 else {
4227 GC_ENTER();
4228 LispObj quote;
4229
4230 list = EVAL(place);
4231 result = CONS(item, list);
4232 GC_PROTECT(result);
4233 quote.type = LispQuote_t;
4234 quote.data.quote = result;
4235 APPLY2(Osetf, place, "e);
4236 GC_LEAVE();
4237 }
4238
4239 return (result);
4240 }
4241
4242 LispObj *
Lisp_Pushnew(LispBuiltin * builtin)4243 Lisp_Pushnew(LispBuiltin *builtin)
4244 /*
4245 pushnew item place &key key test test-not
4246 */
4247 {
4248 GC_ENTER();
4249 LispObj *result, *list;
4250
4251 LispObj *item, *place, *key, *test, *test_not;
4252
4253 test_not = ARGUMENT(4);
4254 test = ARGUMENT(3);
4255 key = ARGUMENT(2);
4256 place = ARGUMENT(1);
4257 item = ARGUMENT(0);
4258
4259 /* Evaluate place */
4260 if (SYMBOLP(place)) {
4261 list = LispGetVar(place);
4262 if (list == NULL)
4263 LispDestroy("EVAL: the variable %s is unbound", STROBJ(place));
4264 /* Do error checking now. */
4265 CHECK_CONSTANT(place);
4266 }
4267 else
4268 /* It is possible that list is not gc protected? */
4269 list = EVAL(place);
4270
4271 item = EVAL(item);
4272 GC_PROTECT(item);
4273 if (key != UNSPEC) {
4274 key = EVAL(key);
4275 GC_PROTECT(key);
4276 }
4277 if (test != UNSPEC) {
4278 test = EVAL(test);
4279 GC_PROTECT(test);
4280 }
4281 else if (test_not != UNSPEC) {
4282 test_not = EVAL(test_not);
4283 GC_PROTECT(test_not);
4284 }
4285
4286 result = LispAdjoin(builtin, item, list, key, test, test_not);
4287
4288 /* Item already in list */
4289 if (result == list) {
4290 GC_LEAVE();
4291
4292 return (result);
4293 }
4294
4295 if (SYMBOLP(place)) {
4296 CHECK_CONSTANT(place);
4297 LispSetVar(place, result);
4298 }
4299 else {
4300 LispObj quote;
4301
4302 GC_PROTECT(result);
4303 quote.type = LispQuote_t;
4304 quote.data.quote = result;
4305 APPLY2(Osetf, place, "e);
4306 }
4307 GC_LEAVE();
4308
4309 return (result);
4310 }
4311
4312 #ifdef __SUNPRO_C
4313 /* prevent "Function has no return statement" error for Lisp_Quit */
4314 #pragma does_not_return(exit)
4315 #endif
4316
4317 LispObj *
Lisp_Quit(LispBuiltin * builtin)4318 Lisp_Quit(LispBuiltin *builtin)
4319 /*
4320 quit &optional status
4321 */
4322 {
4323 int status = 0;
4324 LispObj *ostatus;
4325
4326 ostatus = ARGUMENT(0);
4327
4328 if (FIXNUMP(ostatus))
4329 status = (int)FIXNUM_VALUE(ostatus);
4330 else if (ostatus != UNSPEC)
4331 LispDestroy("%s: bad exit status argument %s",
4332 STRFUN(builtin), STROBJ(ostatus));
4333
4334 exit(status);
4335 }
4336
4337 LispObj *
Lisp_Quote(LispBuiltin * builtin)4338 Lisp_Quote(LispBuiltin *builtin)
4339 /*
4340 quote object
4341 */
4342 {
4343 LispObj *object;
4344
4345 object = ARGUMENT(0);
4346
4347 return (object);
4348 }
4349
4350 LispObj *
Lisp_Replace(LispBuiltin * builtin)4351 Lisp_Replace(LispBuiltin *builtin)
4352 /*
4353 replace sequence1 sequence2 &key start1 end1 start2 end2
4354 */
4355 {
4356 long length, length1, length2, start1, end1, start2, end2;
4357 LispObj *sequence1, *sequence2, *ostart1, *oend1, *ostart2, *oend2;
4358
4359 oend2 = ARGUMENT(5);
4360 ostart2 = ARGUMENT(4);
4361 oend1 = ARGUMENT(3);
4362 ostart1 = ARGUMENT(2);
4363 sequence2 = ARGUMENT(1);
4364 sequence1 = ARGUMENT(0);
4365
4366 LispCheckSequenceStartEnd(builtin, sequence1, ostart1, oend1,
4367 &start1, &end1, &length1);
4368 LispCheckSequenceStartEnd(builtin, sequence2, ostart2, oend2,
4369 &start2, &end2, &length2);
4370
4371 if (start1 == end1 || start2 == end2)
4372 return (sequence1);
4373
4374 length = end1 - start1;
4375 if (length > end2 - start2)
4376 length = end2 - start2;
4377
4378 if (STRINGP(sequence1)) {
4379 CHECK_STRING_WRITABLE(sequence1);
4380 if (!STRINGP(sequence2))
4381 LispDestroy("%s: cannot store %s in %s",
4382 STRFUN(builtin), STROBJ(sequence2), THESTR(sequence1));
4383
4384 memmove(THESTR(sequence1) + start1, THESTR(sequence2) + start2, length);
4385 }
4386 else {
4387 int i;
4388 LispObj *from, *to;
4389
4390 if (ARRAYP(sequence1))
4391 sequence1 = sequence1->data.array.list;
4392 if (ARRAYP(sequence2))
4393 sequence2 = sequence2->data.array.list;
4394
4395 /* adjust pointers */
4396 for (i = 0, from = sequence2; i < start2; i++, from = CDR(from))
4397 ;
4398 for (i = 0, to = sequence1; i < start1; i++, to = CDR(to))
4399 ;
4400
4401 /* copy data */
4402 for (i = 0; i < length; i++, from = CDR(from), to = CDR(to))
4403 RPLACA(to, CAR(from));
4404 }
4405
4406 return (sequence1);
4407 }
4408
4409 static LispObj *
LispDeleteOrRemoveDuplicates(LispBuiltin * builtin,int function)4410 LispDeleteOrRemoveDuplicates(LispBuiltin *builtin, int function)
4411 /*
4412 delete-duplicates sequence &key from-end test test-not start end key
4413 remove-duplicates sequence &key from-end test test-not start end key
4414 */
4415 {
4416 GC_ENTER();
4417 int code, expect, value = 0;
4418 long i, j, start, end, length, count;
4419 LispObj *lambda, *result, *cons, *compare;
4420
4421 LispObj *sequence, *from_end, *test, *test_not, *ostart, *oend, *key;
4422
4423 key = ARGUMENT(6);
4424 oend = ARGUMENT(5);
4425 ostart = ARGUMENT(4);
4426 test_not = ARGUMENT(3);
4427 test = ARGUMENT(2);
4428 from_end = ARGUMENT(1);
4429 if (from_end == UNSPEC)
4430 from_end = NIL;
4431 sequence = ARGUMENT(0);
4432
4433 LispCheckSequenceStartEnd(builtin, sequence, ostart, oend,
4434 &start, &end, &length);
4435
4436 /* Check if need to do something */
4437 if (start == end)
4438 return (sequence);
4439
4440 CHECK_TEST();
4441
4442 /* Initialize */
4443 count = 0;
4444
4445 result = cons = NIL;
4446 if (STRINGP(sequence)) {
4447 char *ptr, *string, *buffer = LispMalloc(length + 1);
4448
4449 /* Use same code, update start/end offsets */
4450 if (from_end != NIL) {
4451 i = length - start;
4452 start = length - end;
4453 end = i;
4454 }
4455
4456 if (from_end == NIL)
4457 string = THESTR(sequence);
4458 else {
4459 /* Make a reversed copy of the sequence */
4460 string = LispMalloc(length + 1);
4461 for (ptr = THESTR(sequence) + length - 1, i = 0; i < length; i++)
4462 string[i] = *ptr--;
4463 string[i] = '\0';
4464 }
4465
4466 ptr = buffer;
4467 /* Copy leading bytes */
4468 for (i = 0; i < start; i++)
4469 *ptr++ = string[i];
4470
4471 compare = SCHAR(string[i]);
4472 if (key != UNSPEC)
4473 compare = APPLY1(key, compare);
4474 result = cons = CONS(compare, NIL);
4475 GC_PROTECT(result);
4476 for (++i; i < end; i++) {
4477 compare = SCHAR(string[i]);
4478 if (key != UNSPEC)
4479 compare = APPLY1(key, compare);
4480 RPLACD(cons, CONS(compare, NIL));
4481 cons = CDR(cons);
4482 }
4483
4484 for (i = start; i < end; i++, result = CDR(result)) {
4485 compare = CAR(result);
4486 for (j = i + 1, cons = CDR(result); j < end; j++, cons = CDR(cons)) {
4487 value = FCOMPARE(lambda, compare, CAR(cons), code);
4488 if (value == expect)
4489 break;
4490 }
4491 if (value != expect)
4492 *ptr++ = string[i];
4493 else
4494 ++count;
4495 }
4496
4497 if (count) {
4498 /* Copy ending bytes */
4499 for (; i <= length; i++) /* Also copy the ending nul */
4500 *ptr++ = string[i];
4501
4502 if (from_end == NIL)
4503 ptr = buffer;
4504 else {
4505 for (i = 0, ptr = buffer + strlen(buffer);
4506 ptr > buffer;
4507 i++)
4508 string[i] = *--ptr;
4509 string[i] = '\0';
4510 ptr = string;
4511 LispFree(buffer);
4512 }
4513 if (function == REMOVE)
4514 result = STRING2(ptr);
4515 else {
4516 CHECK_STRING_WRITABLE(sequence);
4517 result = sequence;
4518 free(THESTR(result));
4519 THESTR(result) = ptr;
4520 LispMused(ptr);
4521 }
4522 }
4523 else {
4524 result = sequence;
4525 if (from_end != NIL)
4526 LispFree(string);
4527 }
4528 }
4529 else {
4530 long xlength = end - start;
4531 LispObj *list, *object, **kobjects = NULL, **xobjects;
4532 LispObj **objects = LispMalloc(sizeof(LispObj*) * xlength);
4533
4534 if (!CONSP(sequence))
4535 object = sequence->data.array.list;
4536 else
4537 object = sequence;
4538 list = object;
4539
4540 for (i = 0; i < start; i++)
4541 object = CDR(object);
4542
4543 /* Put data in a vector */
4544 if (from_end == NIL) {
4545 for (i = 0; i < xlength; i++, object = CDR(object))
4546 objects[i] = CAR(object);
4547 }
4548 else {
4549 for (i = xlength - 1; i >= 0; i--, object = CDR(object))
4550 objects[i] = CAR(object);
4551 }
4552
4553 /* Apply key predicate if required */
4554 if (key != UNSPEC) {
4555 kobjects = LispMalloc(sizeof(LispObj*) * xlength);
4556 for (i = 0; i < xlength; i++) {
4557 kobjects[i] = APPLY1(key, objects[i]);
4558 GC_PROTECT(kobjects[i]);
4559 }
4560 xobjects = kobjects;
4561 }
4562 else
4563 xobjects = objects;
4564
4565 /* Check if needs to remove something */
4566 for (i = 0; i < xlength; i++) {
4567 compare = xobjects[i];
4568 for (j = i + 1; j < xlength; j++) {
4569 value = FCOMPARE(lambda, compare, xobjects[j], code);
4570 if (value == expect) {
4571 objects[i] = NULL;
4572 ++count;
4573 break;
4574 }
4575 }
4576 }
4577
4578 if (count) {
4579 /* Create/set result list */
4580 object = list;
4581
4582 if (start) {
4583 /* Skip first elements of resulting list */
4584 if (function == REMOVE) {
4585 result = cons = CONS(CAR(object), NIL);
4586 GC_PROTECT(result);
4587 for (i = 1, object = CDR(object);
4588 i < start;
4589 i++, object = CDR(object)) {
4590 RPLACD(cons, CONS(CAR(object), NIL));
4591 cons = CDR(cons);
4592 }
4593 }
4594 else {
4595 result = cons = object;
4596 for (i = 1; i < start; i++, cons = CDR(cons))
4597 ;
4598 }
4599 }
4600 else if (function == DELETE)
4601 result = list;
4602
4603 /* Skip initial removed elements */
4604 if (function == REMOVE) {
4605 for (i = 0; objects[i] == NULL && i < xlength; i++)
4606 ;
4607 }
4608 else
4609 i = 0;
4610
4611 if (i < xlength) {
4612 int xstart, xlimit, xinc;
4613
4614 if (from_end == NIL) {
4615 xstart = i;
4616 xlimit = xlength;
4617 xinc = 1;
4618 }
4619 else {
4620 xstart = xlength - 1;
4621 xlimit = i - 1;
4622 xinc = -1;
4623 }
4624
4625 if (function == REMOVE) {
4626 for (i = xstart; i != xlimit; i += xinc) {
4627 if (objects[i] != NULL) {
4628 if (result == NIL) {
4629 result = cons = CONS(objects[i], NIL);
4630 GC_PROTECT(result);
4631 }
4632 else {
4633 RPLACD(cons, CONS(objects[i], NIL));
4634 cons = CDR(cons);
4635 }
4636 }
4637 }
4638 }
4639 else {
4640 /* Delete duplicates */
4641 for (i = xstart; i != xlimit; i += xinc) {
4642 if (objects[i] == NULL) {
4643 if (cons == NIL) {
4644 if (CONSP(CDR(result))) {
4645 RPLACA(result, CADR(result));
4646 RPLACD(result, CDDR(result));
4647 }
4648 else {
4649 RPLACA(result, CDR(result));
4650 RPLACD(result, NIL);
4651 }
4652 }
4653 else {
4654 if (CONSP(CDR(cons)))
4655 RPLACD(cons, CDDR(cons));
4656 else
4657 RPLACD(cons, NIL);
4658 }
4659 }
4660 else {
4661 if (cons == NIL)
4662 cons = result;
4663 else
4664 cons = CDR(cons);
4665 }
4666 }
4667 }
4668 }
4669 if (end < length && function == REMOVE) {
4670 for (i = start; i < end; i++, object = CDR(object))
4671 ;
4672 if (result == NIL) {
4673 result = cons = CONS(CAR(object), NIL);
4674 GC_PROTECT(result);
4675 ++i;
4676 object = CDR(object);
4677 }
4678 for (; i < length; i++, object = CDR(object)) {
4679 RPLACD(cons, CONS(CAR(object), NIL));
4680 cons = CDR(cons);
4681 }
4682 }
4683 }
4684 else
4685 result = sequence;
4686 LispFree(objects);
4687 if (key != UNSPEC)
4688 LispFree(kobjects);
4689
4690 if (count && !CONSP(sequence)) {
4691 if (function == REMOVE)
4692 result = VECTOR(result);
4693 else {
4694 length = FIXNUM_VALUE(CAR(sequence->data.array.dim)) - count;
4695 CAR(sequence->data.array.dim) = FIXNUM(length);
4696 result = sequence;
4697 }
4698 }
4699 }
4700 GC_LEAVE();
4701
4702 return (result);
4703 }
4704
4705 LispObj *
Lisp_RemoveDuplicates(LispBuiltin * builtin)4706 Lisp_RemoveDuplicates(LispBuiltin *builtin)
4707 /*
4708 remove-duplicates sequence &key from-end test test-not start end key
4709 */
4710 {
4711 return (LispDeleteOrRemoveDuplicates(builtin, REMOVE));
4712 }
4713
4714 static LispObj *
LispDeleteRemoveXSubstitute(LispBuiltin * builtin,int function,int comparison)4715 LispDeleteRemoveXSubstitute(LispBuiltin *builtin,
4716 int function, int comparison)
4717 /*
4718 delete item sequence &key from-end test test-not start end count key
4719 delete-if predicate sequence &key from-end start end count key
4720 delete-if-not predicate sequence &key from-end start end count key
4721 remove item sequence &key from-end test test-not start end count key
4722 remove-if predicate sequence &key from-end start end count key
4723 remove-if-not predicate sequence &key from-end start end count key
4724 substitute newitem olditem sequence &key from-end test test-not start end count key
4725 substitute-if newitem test sequence &key from-end start end count key
4726 substitute-if-not newitem test sequence &key from-end start end count key
4727 nsubstitute newitem olditem sequence &key from-end test test-not start end count key
4728 nsubstitute-if newitem test sequence &key from-end start end count key
4729 nsubstitute-if-not newitem test sequence &key from-end start end count key
4730 */
4731 {
4732 GC_ENTER();
4733 int code, expect, value, inplace, substitute;
4734 long i, j, start, end, length, copy, count, xstart, xend, xinc, xlength;
4735
4736 LispObj *result, *compare;
4737
4738 LispObj *item, *newitem, *lambda, *sequence, *from_end,
4739 *test, *test_not, *ostart, *oend, *ocount, *key;
4740
4741 substitute = function == SUBSTITUTE || function == NSUBSTITUTE;
4742 if (!substitute)
4743 i = comparison == NONE ? 8 : 6;
4744 else /* substitute */
4745 i = comparison == NONE ? 9 : 7;
4746
4747 /* Get function arguments */
4748 key = ARGUMENT(i); --i;
4749 ocount = ARGUMENT(i); --i;
4750 oend = ARGUMENT(i); --i;
4751 ostart = ARGUMENT(i); --i;
4752 if (comparison == NONE) {
4753 test_not = ARGUMENT(i); --i;
4754 test = ARGUMENT(i); --i;
4755 }
4756 else
4757 test_not = test = UNSPEC;
4758 from_end = ARGUMENT(i); --i;
4759 if (from_end == UNSPEC)
4760 from_end = NIL;
4761 sequence = ARGUMENT(i); --i;
4762 if (comparison != NONE) {
4763 lambda = ARGUMENT(i); --i;
4764 if (substitute)
4765 newitem = ARGUMENT(0);
4766 else
4767 newitem = NIL;
4768 item = NIL;
4769 }
4770 else {
4771 lambda = NIL;
4772 if (substitute) {
4773 item = ARGUMENT(1);
4774 newitem = ARGUMENT(0);
4775 }
4776 else {
4777 item = ARGUMENT(0);
4778 newitem = NIL;
4779 }
4780 }
4781
4782 /* Check if argument is a valid sequence, and if start/end
4783 * are correctly specified. */
4784 LispCheckSequenceStartEnd(builtin, sequence, ostart, oend,
4785 &start, &end, &length);
4786
4787 /* Check count argument */
4788 if (ocount == UNSPEC) {
4789 count = length;
4790 /* Doesn't matter, but left to right should be slightly faster */
4791 from_end = NIL;
4792 }
4793 else {
4794 CHECK_INDEX(ocount);
4795 count = FIXNUM_VALUE(ocount);
4796 }
4797
4798 /* Check if need to do something */
4799 if (start == end || count == 0)
4800 return (sequence);
4801
4802 CHECK_TEST_0();
4803
4804 /* Resolve comparison function, and expected result of comparison */
4805 if (comparison == NONE) {
4806 if (test_not == UNSPEC) {
4807 if (test == UNSPEC)
4808 lambda = Oeql;
4809 else
4810 lambda = test;
4811 expect = 1;
4812 }
4813 else {
4814 lambda = test_not;
4815 expect = 0;
4816 }
4817 FUNCTION_CHECK(lambda);
4818 }
4819 else
4820 expect = comparison == IFNOT ? 0 : 1;
4821
4822 /* Check for fast path to comparison function */
4823 code = FCODE(lambda);
4824
4825 /* Initialize for loop */
4826 copy = count;
4827 result = sequence;
4828 inplace = function == DELETE || function == NSUBSTITUTE;
4829 xlength = end - start;
4830
4831 /* String is easier */
4832 if (STRINGP(sequence)) {
4833 char *buffer, *string;
4834
4835 if (comparison == NONE) {
4836 CHECK_SCHAR(item);
4837 }
4838 if (substitute) {
4839 CHECK_SCHAR(newitem);
4840 }
4841
4842 if (from_end == NIL) {
4843 xstart = start;
4844 xend = end;
4845 xinc = 1;
4846 }
4847 else {
4848 xstart = end - 1;
4849 xend = start - 1;
4850 xinc = -1;
4851 }
4852
4853 string = THESTR(sequence);
4854 buffer = LispMalloc(length + 1);
4855
4856 /* Copy leading bytes, if any */
4857 for (i = 0; i < start; i++)
4858 buffer[i] = string[i];
4859
4860 for (j = xstart; i != xend && count > 0; i += xinc) {
4861 compare = SCHAR(string[i]);
4862 if (key != UNSPEC) {
4863 compare = APPLY1(key, compare);
4864 /* Value returned by the key predicate may not be protected */
4865 GC_PROTECT(compare);
4866 if (comparison == NONE)
4867 value = FCOMPARE(lambda, item, compare, code);
4868 else
4869 value = APPLY1(lambda, compare) != NIL;
4870 /* Unprotect value returned by the key predicate */
4871 GC_LEAVE();
4872 }
4873 else {
4874 if (comparison == NONE)
4875 value = FCOMPARE(lambda, item, compare, code);
4876 else
4877 value = APPLY1(lambda, compare) != NIL;
4878 }
4879
4880 if (value != expect) {
4881 buffer[j] = string[i];
4882 j += xinc;
4883 }
4884 else {
4885 if (substitute) {
4886 buffer[j] = SCHAR_VALUE(newitem);
4887 j += xinc;
4888 }
4889 else
4890 --count;
4891 }
4892 }
4893
4894 if (count != copy && from_end != NIL)
4895 memmove(buffer + start, buffer + copy - count, count);
4896
4897 /* Copy remaining bytes, if any */
4898 for (; i < length; i++, j++)
4899 buffer[j] = string[i];
4900 buffer[j] = '\0';
4901
4902 xlength = length - (copy - count);
4903 if (inplace) {
4904 CHECK_STRING_WRITABLE(sequence);
4905 /* result is a pointer to sequence */
4906 LispFree(THESTR(sequence));
4907 LispMused(buffer);
4908 THESTR(sequence) = buffer;
4909 STRLEN(sequence) = xlength;
4910 }
4911 else
4912 result = LSTRING2(buffer, xlength);
4913 }
4914
4915 /* If inplace, need to update CAR and CDR of sequence */
4916 else {
4917 LispObj *list, *object;
4918 LispObj **objects = LispMalloc(sizeof(LispObj*) * xlength);
4919
4920 if (!CONSP(sequence))
4921 list = sequence->data.array.list;
4922 else
4923 list = sequence;
4924
4925 /* Put data in a vector */
4926 for (i = 0, object = list; i < start; i++)
4927 object = CDR(object);
4928
4929 for (i = 0; i < xlength; i++, object = CDR(object))
4930 objects[i] = CAR(object);
4931
4932 if (from_end == NIL) {
4933 xstart = 0;
4934 xend = xlength;
4935 xinc = 1;
4936 }
4937 else {
4938 xstart = xlength - 1;
4939 xend = -1;
4940 xinc = -1;
4941 }
4942
4943 /* Check if needs to remove something */
4944 for (i = xstart; i != xend && count > 0; i += xinc) {
4945 compare = objects[i];
4946 if (key != UNSPEC) {
4947 compare = APPLY1(key, compare);
4948 GC_PROTECT(compare);
4949 if (comparison == NONE)
4950 value = FCOMPARE(lambda, item, compare, code);
4951 else
4952 value = APPLY1(lambda, compare) != NIL;
4953 GC_LEAVE();
4954 }
4955 else {
4956 if (comparison == NONE)
4957 value = FCOMPARE(lambda, item, compare, code);
4958 else
4959 value = APPLY1(lambda, compare) != NIL;
4960 }
4961 if (value == expect) {
4962 if (substitute)
4963 objects[i] = newitem;
4964 else
4965 objects[i] = NULL;
4966 --count;
4967 }
4968 }
4969
4970 if (copy != count) {
4971 LispObj *cons = NIL;
4972
4973 i = 0;
4974 object = list;
4975 if (inplace) {
4976 /* While result is NIL, skip initial elements of sequence */
4977 result = start ? list : NIL;
4978
4979 /* Skip initial elements, if any */
4980 for (; i < start; i++, cons = object, object = CDR(object))
4981 ;
4982 }
4983 /* Copy initial elements, if any */
4984 else {
4985 result = NIL;
4986 if (start) {
4987 result = cons = CONS(CAR(list), NIL);
4988 GC_PROTECT(result);
4989 for (++i, object = CDR(list);
4990 i < start;
4991 i++, object = CDR(object)) {
4992 RPLACD(cons, CONS(CAR(object), NIL));
4993 cons = CDR(cons);
4994 }
4995 }
4996 }
4997
4998 /* Skip initial removed elements, if any */
4999 for (i = 0; i < xlength && objects[i] == NULL; i++)
5000 ;
5001
5002 for (i = 0; i < xlength; i++, object = CDR(object)) {
5003 if (objects[i]) {
5004 if (inplace) {
5005 if (result == NIL)
5006 result = cons = object;
5007 else {
5008 RPLACD(cons, object);
5009 cons = CDR(cons);
5010 }
5011 if (function == NSUBSTITUTE)
5012 RPLACA(cons, objects[i]);
5013 }
5014 else {
5015 if (result == NIL) {
5016 result = cons = CONS(objects[i], NIL);
5017 GC_PROTECT(result);
5018 }
5019 else {
5020 RPLACD(cons, CONS(objects[i], NIL));
5021 cons = CDR(cons);
5022 }
5023 }
5024 }
5025 }
5026
5027 if (inplace) {
5028 if (result == NIL)
5029 result = object;
5030 else
5031 RPLACD(cons, object);
5032
5033 if (!CONSP(sequence)) {
5034 result = sequence;
5035 CAR(result)->data.array.dim =
5036 FIXNUM(length - (copy - count));
5037 }
5038 }
5039 else if (end < length) {
5040 i = end;
5041 /* Copy ending elements, if any */
5042 if (result == NIL) {
5043 result = cons = CONS(CAR(object), NIL);
5044 GC_PROTECT(result);
5045 object = CDR(object);
5046 i++;
5047 }
5048 for (; i < length; i++, object = CDR(object)) {
5049 RPLACD(cons, CONS(CAR(object), NIL));
5050 cons = CDR(cons);
5051 }
5052 }
5053 }
5054
5055 /* Release comparison vector */
5056 LispFree(objects);
5057 }
5058
5059 GC_LEAVE();
5060
5061 return (result);
5062 }
5063
5064 LispObj *
Lisp_Remove(LispBuiltin * builtin)5065 Lisp_Remove(LispBuiltin *builtin)
5066 /*
5067 remove item sequence &key from-end test test-not start end count key
5068 */
5069 {
5070 return (LispDeleteRemoveXSubstitute(builtin, REMOVE, NONE));
5071 }
5072
5073 LispObj *
Lisp_RemoveIf(LispBuiltin * builtin)5074 Lisp_RemoveIf(LispBuiltin *builtin)
5075 /*
5076 remove-if predicate sequence &key from-end start end count key
5077 */
5078 {
5079 return (LispDeleteRemoveXSubstitute(builtin, REMOVE, IF));
5080 }
5081
5082 LispObj *
Lisp_RemoveIfNot(LispBuiltin * builtin)5083 Lisp_RemoveIfNot(LispBuiltin *builtin)
5084 /*
5085 remove-if-not predicate sequence &key from-end start end count key
5086 */
5087 {
5088 return (LispDeleteRemoveXSubstitute(builtin, REMOVE, IFNOT));
5089 }
5090
5091 LispObj *
Lisp_Remprop(LispBuiltin * builtin)5092 Lisp_Remprop(LispBuiltin *builtin)
5093 /*
5094 remprop symbol indicator
5095 */
5096 {
5097 LispObj *symbol, *indicator;
5098
5099 indicator = ARGUMENT(1);
5100 symbol = ARGUMENT(0);
5101
5102 CHECK_SYMBOL(symbol);
5103
5104 return (LispRemAtomProperty(symbol->data.atom, indicator));
5105 }
5106
5107 LispObj *
Lisp_Return(LispBuiltin * builtin)5108 Lisp_Return(LispBuiltin *builtin)
5109 /*
5110 return &optional result
5111 */
5112 {
5113 unsigned blevel = lisp__data.block.block_level;
5114
5115 LispObj *result;
5116
5117 result = ARGUMENT(0);
5118
5119 while (blevel) {
5120 LispBlock *block = lisp__data.block.block[--blevel];
5121
5122 if (block->type == LispBlockClosure)
5123 /* if reached a function call */
5124 break;
5125 if (block->type == LispBlockTag && block->tag == NIL) {
5126 lisp__data.block.block_ret = result == UNSPEC ? NIL : EVAL(result);
5127 LispBlockUnwind(block);
5128 BLOCKJUMP(block);
5129 }
5130 }
5131 LispDestroy("%s: no visible NIL block", STRFUN(builtin));
5132
5133 /*NOTREACHED*/
5134 return (NIL);
5135 }
5136
5137 LispObj *
Lisp_ReturnFrom(LispBuiltin * builtin)5138 Lisp_ReturnFrom(LispBuiltin *builtin)
5139 /*
5140 return-from name &optional result
5141 */
5142 {
5143 unsigned blevel = lisp__data.block.block_level;
5144
5145 LispObj *name, *result;
5146
5147 result = ARGUMENT(1);
5148 name = ARGUMENT(0);
5149
5150 if (name != NIL && name != T && !SYMBOLP(name))
5151 LispDestroy("%s: %s is not a valid block name",
5152 STRFUN(builtin), STROBJ(name));
5153
5154 while (blevel) {
5155 LispBlock *block = lisp__data.block.block[--blevel];
5156
5157 if (name == block->tag &&
5158 (block->type == LispBlockTag || block->type == LispBlockClosure)) {
5159 lisp__data.block.block_ret = result == UNSPEC ? NIL : EVAL(result);
5160 LispBlockUnwind(block);
5161 BLOCKJUMP(block);
5162 }
5163 if (block->type == LispBlockClosure)
5164 /* can use return-from only in the current function */
5165 break;
5166 }
5167 LispDestroy("%s: no visible block named %s",
5168 STRFUN(builtin), STROBJ(name));
5169
5170 /*NOTREACHED*/
5171 return (NIL);
5172 }
5173
5174 static LispObj *
LispXReverse(LispBuiltin * builtin,int inplace)5175 LispXReverse(LispBuiltin *builtin, int inplace)
5176 /*
5177 nreverse sequence
5178 reverse sequence
5179 */
5180 {
5181 long length;
5182 LispObj *list, *result = NIL;
5183
5184 LispObj *sequence;
5185
5186 sequence = ARGUMENT(0);
5187
5188 /* Do error checking for arrays and object type. */
5189 length = LispLength(sequence);
5190 if (length <= 1)
5191 return (sequence);
5192
5193 switch (XOBJECT_TYPE(sequence)) {
5194 case LispString_t: {
5195 long i;
5196 char *from, *to;
5197
5198 from = THESTR(sequence) + length - 1;
5199 if (inplace) {
5200 char temp;
5201
5202 CHECK_STRING_WRITABLE(sequence);
5203 to = THESTR(sequence);
5204 for (i = 0; i < length / 2; i++) {
5205 temp = to[i];
5206 to[i] = from[-i];
5207 from[-i] = temp;
5208 }
5209 result = sequence;
5210 }
5211 else {
5212 to = LispMalloc(length + 1);
5213 to[length] = '\0';
5214 for (i = 0; i < length; i++)
5215 to[i] = from[-i];
5216 result = STRING2(to);
5217 }
5218 } return (result);
5219 case LispCons_t:
5220 if (inplace) {
5221 long i, j;
5222 LispObj *temp;
5223
5224 /* For large lists this can be very slow, but for small
5225 * amounts of data, this avoid allocating a buffer to
5226 * to store the CAR of the sequence. This is only done
5227 * to not destroy the contents of a variable.
5228 */
5229 for (i = 0, list = sequence;
5230 i < (length + 1) / 2;
5231 i++, list = CDR(list))
5232 ;
5233 length /= 2;
5234 for (i = 0; i < length; i++, list = CDR(list)) {
5235 for (j = length - i - 1, result = sequence;
5236 j > 0;
5237 j--, result = CDR(result))
5238 ;
5239 temp = CAR(list);
5240 RPLACA(list, CAR(result));
5241 RPLACA(result, temp);
5242 }
5243 return (sequence);
5244 }
5245 list = sequence;
5246 break;
5247 case LispArray_t:
5248 if (inplace) {
5249 sequence->data.array.list =
5250 LispReverse(sequence->data.array.list);
5251 return (sequence);
5252 }
5253 list = sequence->data.array.list;
5254 break;
5255 default: /* LispNil_t */
5256 return (result);
5257 }
5258
5259 {
5260 GC_ENTER();
5261 LispObj *cons;
5262
5263 result = cons = CONS(CAR(list), NIL);
5264 GC_PROTECT(result);
5265 for (list = CDR(list); CONSP(list); list = CDR(list)) {
5266 RPLACD(cons, CONS(CAR(list), NIL));
5267 cons = CDR(cons);
5268 }
5269 result = LispReverse(result);
5270
5271 GC_LEAVE();
5272 }
5273
5274 if (ARRAYP(sequence)) {
5275 list = result;
5276
5277 result = LispNew(list, NIL);
5278 result->type = LispArray_t;
5279 result->data.array.list = list;
5280 result->data.array.dim = sequence->data.array.dim;
5281 result->data.array.rank = sequence->data.array.rank;
5282 result->data.array.type = sequence->data.array.type;
5283 result->data.array.zero = sequence->data.array.zero;
5284 }
5285
5286 return (result);
5287 }
5288
5289 LispObj *
Lisp_Reverse(LispBuiltin * builtin)5290 Lisp_Reverse(LispBuiltin *builtin)
5291 /*
5292 reverse sequence
5293 */
5294 {
5295 return (LispXReverse(builtin, 0));
5296 }
5297
5298 LispObj *
Lisp_Rplaca(LispBuiltin * builtin)5299 Lisp_Rplaca(LispBuiltin *builtin)
5300 /*
5301 rplaca place value
5302 */
5303 {
5304 LispObj *place, *value;
5305
5306 value = ARGUMENT(1);
5307 place = ARGUMENT(0);
5308
5309 CHECK_CONS(place);
5310 RPLACA(place, value);
5311
5312 return (place);
5313 }
5314
5315 LispObj *
Lisp_Rplacd(LispBuiltin * builtin)5316 Lisp_Rplacd(LispBuiltin *builtin)
5317 /*
5318 rplacd place value
5319 */
5320 {
5321 LispObj *place, *value;
5322
5323 value = ARGUMENT(1);
5324 place = ARGUMENT(0);
5325
5326 CHECK_CONS(place);
5327 RPLACD(place, value);
5328
5329 return (place);
5330 }
5331
5332 LispObj *
Lisp_Search(LispBuiltin * builtin)5333 Lisp_Search(LispBuiltin *builtin)
5334 /*
5335 search sequence1 sequence2 &key from-end test test-not key start1 start2 end1 end2
5336 */
5337 {
5338 int code = 0, expect, value;
5339 long start1, start2, end1, end2, length1, length2, off1, off2, offset = -1;
5340 LispObj *cmp1, *cmp2, *list1 = NIL, *lambda;
5341 SeqInfo seq1, seq2;
5342
5343 LispObj *sequence1, *sequence2, *from_end, *test, *test_not,
5344 *key, *ostart1, *ostart2, *oend1, *oend2;
5345
5346 oend2 = ARGUMENT(9);
5347 oend1 = ARGUMENT(8);
5348 ostart2 = ARGUMENT(7);
5349 ostart1 = ARGUMENT(6);
5350 key = ARGUMENT(5);
5351 test_not = ARGUMENT(4);
5352 test = ARGUMENT(3);
5353 from_end = ARGUMENT(2);
5354 sequence2 = ARGUMENT(1);
5355 sequence1 = ARGUMENT(0);
5356
5357 LispCheckSequenceStartEnd(builtin, sequence1, ostart1, oend1,
5358 &start1, &end1, &length1);
5359 LispCheckSequenceStartEnd(builtin, sequence2, ostart2, oend2,
5360 &start2, &end2, &length2);
5361
5362 /* Check for special conditions */
5363 if (start1 == end1)
5364 return (FIXNUM(end2));
5365 else if (start2 == end2)
5366 return (start1 == end1 ? FIXNUM(start2) : NIL);
5367
5368 CHECK_TEST();
5369
5370 if (from_end == UNSPEC)
5371 from_end = NIL;
5372
5373 SETSEQ(seq1, sequence1);
5374 SETSEQ(seq2, sequence2);
5375
5376 length1 = end1 - start1;
5377 length2 = end2 - start2;
5378
5379 /* update start of sequences */
5380 if (start1) {
5381 if (seq1.type == LispString_t)
5382 seq1.data.string += start1;
5383 else {
5384 for (cmp1 = seq1.data.list; start1; cmp1 = CDR(cmp1), --start1)
5385 ;
5386 seq1.data.list = cmp1;
5387 }
5388 end1 = length1;
5389 }
5390 if (start2) {
5391 if (seq2.type == LispString_t)
5392 seq2.data.string += start2;
5393 else {
5394 for (cmp2 = seq2.data.list; start2; cmp2 = CDR(cmp2), --start2)
5395 ;
5396 seq2.data.list = cmp2;
5397 }
5398 end2 = length2;
5399 }
5400
5401 /* easier case */
5402 if (from_end == NIL) {
5403 LispObj *list2 = NIL;
5404
5405 /* while a match is possible */
5406 while (end2 - start2 >= length1) {
5407
5408 /* prepare to search */
5409 off1 = 0;
5410 off2 = start2;
5411 if (seq1.type != LispString_t)
5412 list1 = seq1.data.list;
5413 if (seq2.type != LispString_t)
5414 list2 = seq2.data.list;
5415
5416 /* for every element that must match in sequence1 */
5417 while (off1 < length1) {
5418 if (seq1.type == LispString_t)
5419 cmp1 = SCHAR(seq1.data.string[off1]);
5420 else
5421 cmp1 = CAR(list1);
5422 if (seq2.type == LispString_t)
5423 cmp2 = SCHAR(seq2.data.string[off2]);
5424 else
5425 cmp2 = CAR(list2);
5426 if (key != UNSPEC) {
5427 cmp1 = APPLY1(key, cmp1);
5428 cmp2 = APPLY1(key, cmp2);
5429 }
5430
5431 /* compare elements */
5432 value = FCOMPARE(lambda, cmp1, cmp2, code);
5433 if (value != expect)
5434 break;
5435
5436 /* update offsets/sequence pointers */
5437 ++off1;
5438 ++off2;
5439 if (seq1.type != LispString_t)
5440 list1 = CDR(list1);
5441 if (seq2.type != LispString_t)
5442 list2 = CDR(list2);
5443 }
5444
5445 /* if everything matched */
5446 if (off1 == end1) {
5447 offset = off2 - length1;
5448 break;
5449 }
5450
5451 /* update offset/sequence2 pointer */
5452 ++start2;
5453 if (seq2.type != LispString_t)
5454 seq2.data.list = CDR(seq2.data.list);
5455 }
5456 }
5457 else {
5458 /* allocate vector if required, only list2 requires it.
5459 * list1 can be traversed forward */
5460 if (seq2.type != LispString_t) {
5461 cmp2 = seq2.data.list;
5462 seq2.data.vector = LispMalloc(sizeof(LispObj*) * length2);
5463 for (off2 = 0; off2 < end2; off2++, cmp2 = CDR(cmp2))
5464 seq2.data.vector[off2] = CAR(cmp2);
5465 }
5466
5467 /* while a match is possible */
5468 while (end2 >= length1) {
5469
5470 /* prepare to search */
5471 off1 = 0;
5472 off2 = end2 - length1;
5473 if (seq1.type != LispString_t)
5474 list1 = seq1.data.list;
5475
5476 /* for every element that must match in sequence1 */
5477 while (off1 < end1) {
5478 if (seq1.type == LispString_t)
5479 cmp1 = SCHAR(seq1.data.string[off1]);
5480 else
5481 cmp1 = CAR(list1);
5482 if (seq2.type == LispString_t)
5483 cmp2 = SCHAR(seq2.data.string[off2]);
5484 else
5485 cmp2 = seq2.data.vector[off2];
5486 if (key != UNSPEC) {
5487 cmp1 = APPLY1(key, cmp1);
5488 cmp2 = APPLY1(key, cmp2);
5489 }
5490
5491 /* Compare elements */
5492 value = FCOMPARE(lambda, cmp1, cmp2, code);
5493 if (value != expect)
5494 break;
5495
5496 /* Update offsets */
5497 ++off1;
5498 ++off2;
5499 if (seq1.type != LispString_t)
5500 list1 = CDR(list1);
5501 }
5502
5503 /* If all elements matched */
5504 if (off1 == end1) {
5505 offset = off2 - length1;
5506 break;
5507 }
5508
5509 /* Update offset */
5510 --end2;
5511 }
5512
5513 if (seq2.type != LispString_t)
5514 LispFree(seq2.data.vector);
5515 }
5516
5517 return (offset == -1 ? NIL : FIXNUM(offset));
5518 }
5519
5520 /*
5521 * ext::getenv
5522 */
5523 LispObj *
Lisp_Setenv(LispBuiltin * builtin)5524 Lisp_Setenv(LispBuiltin *builtin)
5525 /*
5526 setenv name value &optional overwrite
5527 */
5528 {
5529 char *name, *value;
5530
5531 LispObj *oname, *ovalue, *overwrite;
5532
5533 overwrite = ARGUMENT(2);
5534 ovalue = ARGUMENT(1);
5535 oname = ARGUMENT(0);
5536
5537 CHECK_STRING(oname);
5538 name = THESTR(oname);
5539
5540 CHECK_STRING(ovalue);
5541 value = THESTR(ovalue);
5542
5543 setenv(name, value, overwrite != UNSPEC && overwrite != NIL);
5544 value = getenv(name);
5545
5546 return (value ? STRING(value) : NIL);
5547 }
5548
5549 LispObj *
Lisp_Set(LispBuiltin * builtin)5550 Lisp_Set(LispBuiltin *builtin)
5551 /*
5552 set symbol value
5553 */
5554 {
5555 LispAtom *atom;
5556 LispObj *symbol, *value;
5557
5558 value = ARGUMENT(1);
5559 symbol = ARGUMENT(0);
5560
5561 CHECK_SYMBOL(symbol);
5562 atom = symbol->data.atom;
5563 if (atom->dyn)
5564 LispSetVar(symbol, value);
5565 else if (atom->watch || !atom->a_object)
5566 LispSetAtomObjectProperty(atom, value);
5567 else {
5568 CHECK_CONSTANT(symbol);
5569 SETVALUE(atom, value);
5570 }
5571
5572 return (value);
5573 }
5574
5575 LispObj *
Lisp_SetDifference(LispBuiltin * builtin)5576 Lisp_SetDifference(LispBuiltin *builtin)
5577 /*
5578 set-difference list1 list2 &key test test-not key
5579 */
5580 {
5581 return (LispListSet(builtin, SETDIFFERENCE));
5582 }
5583
5584 LispObj *
Lisp_SetExclusiveOr(LispBuiltin * builtin)5585 Lisp_SetExclusiveOr(LispBuiltin *builtin)
5586 /*
5587 set-exclusive-or list1 list2 &key test test-not key
5588 */
5589 {
5590 return (LispListSet(builtin, SETEXCLUSIVEOR));
5591 }
5592
5593 LispObj *
Lisp_NsetExclusiveOr(LispBuiltin * builtin)5594 Lisp_NsetExclusiveOr(LispBuiltin *builtin)
5595 /*
5596 nset-exclusive-or list1 list2 &key test test-not key
5597 */
5598 {
5599 return (LispListSet(builtin, NSETEXCLUSIVEOR));
5600 }
5601
5602 LispObj *
Lisp_SetQ(LispBuiltin * builtin)5603 Lisp_SetQ(LispBuiltin *builtin)
5604 /*
5605 setq &rest form
5606 */
5607 {
5608 LispObj *result, *variable, *form;
5609
5610 form = ARGUMENT(0);
5611
5612 result = NIL;
5613 for (; CONSP(form); form = CDR(form)) {
5614 variable = CAR(form);
5615 CHECK_SYMBOL(variable);
5616 CHECK_CONSTANT(variable);
5617 form = CDR(form);
5618 if (!CONSP(form))
5619 LispDestroy("%s: odd number of arguments", STRFUN(builtin));
5620 result = EVAL(CAR(form));
5621 LispSetVar(variable, result);
5622 }
5623
5624 return (result);
5625 }
5626
5627 LispObj *
Lisp_Psetq(LispBuiltin * builtin)5628 Lisp_Psetq(LispBuiltin *builtin)
5629 /*
5630 psetq &rest form
5631 */
5632 {
5633 GC_ENTER();
5634 int base = gc__protect;
5635 LispObj *value, *symbol, *list, *form;
5636
5637 form = ARGUMENT(0);
5638
5639 /* parallel setq, first pass evaluate values and basic error checking */
5640 for (list = form; CONSP(list); list = CDR(list)) {
5641 symbol = CAR(list);
5642 CHECK_SYMBOL(symbol);
5643 list = CDR(list);
5644 if (!CONSP(list))
5645 LispDestroy("%s: odd number of arguments", STRFUN(builtin));
5646 value = EVAL(CAR(list));
5647 GC_PROTECT(value);
5648 }
5649
5650 /* second pass, assign values */
5651 for (; CONSP(form); form = CDDR(form)) {
5652 symbol = CAR(form);
5653 CHECK_CONSTANT(symbol);
5654 LispSetVar(symbol, lisp__data.protect.objects[base++]);
5655 }
5656 GC_LEAVE();
5657
5658 return (NIL);
5659 }
5660
5661 LispObj *
Lisp_Setf(LispBuiltin * builtin)5662 Lisp_Setf(LispBuiltin *builtin)
5663 /*
5664 setf &rest form
5665 */
5666 {
5667 LispAtom *atom;
5668 LispObj *setf, *place, *value, *result = NIL, *data;
5669
5670 LispObj *form;
5671
5672 form = ARGUMENT(0);
5673
5674 for (; CONSP(form); form = CDR(form)) {
5675 place = CAR(form);
5676 form = CDR(form);
5677 if (!CONSP(form))
5678 LispDestroy("%s: odd number of arguments", STRFUN(builtin));
5679 value = CAR(form);
5680
5681 if (!POINTERP(place))
5682 goto invalid_place;
5683 if (XSYMBOLP(place)) {
5684 CHECK_CONSTANT(place);
5685 result = EVAL(value);
5686 (void)LispSetVar(place, result);
5687 }
5688 else if (XCONSP(place)) {
5689 /* it really should not be required to protect any object
5690 * evaluated here, but is done for safety in case one of
5691 * the evaluated forms returns data not gc protected, what
5692 * could cause surprises if the object is garbage collected
5693 * before finishing setf. */
5694 GC_ENTER();
5695
5696 setf = CAR(place);
5697 if (!SYMBOLP(setf))
5698 goto invalid_place;
5699 if (!CONSP(CDR(place)))
5700 goto invalid_place;
5701
5702 value = EVAL(value);
5703 GC_PROTECT(value);
5704
5705 atom = setf->data.atom;
5706 if (atom->a_defsetf == 0) {
5707 if (atom->a_defstruct &&
5708 atom->property->structure.function >= 0) {
5709 /* Use a default setf method for the structure field, as
5710 * if this definition have been done
5711 * (defsetf THE-STRUCT-FIELD (struct) (value)
5712 * `(lisp::struct-store 'THE-STRUCT-FIELD ,struct ,value))
5713 */
5714 place = CDR(place);
5715 data = CAR(place);
5716 if (CONSP(CDR(place)))
5717 goto invalid_place;
5718 data = EVAL(data);
5719 GC_PROTECT(data);
5720 result = APPLY3(Ostruct_store, setf, data, value);
5721 GC_LEAVE();
5722 continue;
5723 }
5724 /* Must also expand macros */
5725 else if (atom->a_function &&
5726 atom->property->fun.function->funtype == LispMacro) {
5727 result = LispRunSetfMacro(atom, CDR(place), value);
5728 continue;
5729 }
5730 goto invalid_place;
5731 }
5732
5733 place = CDR(place);
5734 setf = setf->data.atom->property->setf;
5735 if (SYMBOLP(setf)) {
5736 LispObj *arguments, *cons;
5737
5738 if (!CONSP(CDR(place))) {
5739 arguments = EVAL(CAR(place));
5740 GC_PROTECT(arguments);
5741 result = APPLY2(setf, arguments, value);
5742 }
5743 else if (!CONSP(CDDR(place))) {
5744 arguments = EVAL(CAR(place));
5745 GC_PROTECT(arguments);
5746 cons = EVAL(CADR(place));
5747 GC_PROTECT(cons);
5748 result = APPLY3(setf, arguments, cons, value);
5749 }
5750 else {
5751 arguments = cons = CONS(EVAL(CAR(place)), NIL);
5752 GC_PROTECT(arguments);
5753 for (place = CDR(place); CONSP(place); place = CDR(place)) {
5754 RPLACD(cons, CONS(EVAL(CAR(place)), NIL));
5755 cons = CDR(cons);
5756 }
5757 RPLACD(cons, CONS(value, NIL));
5758 result = APPLY(setf, arguments);
5759 }
5760 }
5761 else
5762 result = LispRunSetf(atom->property->salist, setf, place, value);
5763 GC_LEAVE();
5764 }
5765 else
5766 goto invalid_place;
5767 }
5768
5769 return (result);
5770 invalid_place:
5771 LispDestroy("%s: %s is an invalid place", STRFUN(builtin), STROBJ(place));
5772 /*NOTREACHED*/
5773 return (NIL);
5774 }
5775
5776 LispObj *
Lisp_Psetf(LispBuiltin * builtin)5777 Lisp_Psetf(LispBuiltin *builtin)
5778 /*
5779 psetf &rest form
5780 */
5781 {
5782 int base;
5783 GC_ENTER();
5784 LispAtom *atom;
5785 LispObj *setf, *place = NIL, *value, *data;
5786
5787 LispObj *form;
5788
5789 form = ARGUMENT(0);
5790
5791 /* parallel setf, first pass evaluate values and basic error checking */
5792 base = gc__protect;
5793 for (setf = form; CONSP(setf); setf = CDR(setf)) {
5794 if (!POINTERP(CAR(setf)))
5795 goto invalid_place;
5796 setf = CDR(setf);
5797 if (!CONSP(setf))
5798 LispDestroy("%s: odd number of arguments", STRFUN(builtin));
5799 value = EVAL(CAR(setf));
5800 GC_PROTECT(value);
5801 }
5802
5803 /* second pass, assign values */
5804 for (; CONSP(form); form = CDDR(form)) {
5805 place = CAR(form);
5806 value = lisp__data.protect.objects[base++];
5807
5808 if (XSYMBOLP(place)) {
5809 CHECK_CONSTANT(place);
5810 (void)LispSetVar(place, value);
5811 }
5812 else if (XCONSP(place)) {
5813 LispObj *arguments, *cons;
5814 int xbase = lisp__data.protect.length;
5815
5816 setf = CAR(place);
5817 if (!SYMBOLP(setf))
5818 goto invalid_place;
5819 if (!CONSP(CDR(place)))
5820 goto invalid_place;
5821
5822 atom = setf->data.atom;
5823 if (atom->a_defsetf == 0) {
5824 if (atom->a_defstruct &&
5825 atom->property->structure.function >= 0) {
5826 place = CDR(place);
5827 data = CAR(place);
5828 if (CONSP(CDR(place)))
5829 goto invalid_place;
5830 data = EVAL(data);
5831 GC_PROTECT(data);
5832 (void)APPLY3(Ostruct_store, setf, data, value);
5833 lisp__data.protect.length = xbase;
5834 continue;
5835 }
5836 else if (atom->a_function &&
5837 atom->property->fun.function->funtype == LispMacro) {
5838 (void)LispRunSetfMacro(atom, CDR(place), value);
5839 lisp__data.protect.length = xbase;
5840 continue;
5841 }
5842 goto invalid_place;
5843 }
5844
5845 place = CDR(place);
5846 setf = setf->data.atom->property->setf;
5847 if (SYMBOLP(setf)) {
5848 if (!CONSP(CDR(place))) {
5849 arguments = EVAL(CAR(place));
5850 GC_PROTECT(arguments);
5851 (void)APPLY2(setf, arguments, value);
5852 }
5853 else if (!CONSP(CDDR(place))) {
5854 arguments = EVAL(CAR(place));
5855 GC_PROTECT(arguments);
5856 cons = EVAL(CADR(place));
5857 GC_PROTECT(cons);
5858 (void)APPLY3(setf, arguments, cons, value);
5859 }
5860 else {
5861 arguments = cons = CONS(EVAL(CAR(place)), NIL);
5862 GC_PROTECT(arguments);
5863 for (place = CDR(place); CONSP(place); place = CDR(place)) {
5864 RPLACD(cons, CONS(EVAL(CAR(place)), NIL));
5865 cons = CDR(cons);
5866 }
5867 RPLACD(cons, CONS(value, NIL));
5868 (void)APPLY(setf, arguments);
5869 }
5870 lisp__data.protect.length = xbase;
5871 }
5872 else
5873 (void)LispRunSetf(atom->property->salist, setf, place, value);
5874 }
5875 else
5876 goto invalid_place;
5877 }
5878 GC_LEAVE();
5879
5880 return (NIL);
5881 invalid_place:
5882 LispDestroy("%s: %s is an invalid place", STRFUN(builtin), STROBJ(place));
5883 /*NOTREACHED*/
5884 return (NIL);
5885 }
5886
5887 LispObj *
Lisp_Sleep(LispBuiltin * builtin)5888 Lisp_Sleep(LispBuiltin *builtin)
5889 /*
5890 sleep seconds
5891 */
5892 {
5893 long sec, msec;
5894 double value, dsec;
5895
5896 LispObj *seconds;
5897
5898 seconds = ARGUMENT(0);
5899
5900 value = -1.0;
5901 switch (OBJECT_TYPE(seconds)) {
5902 case LispFixnum_t:
5903 value = FIXNUM_VALUE(seconds);
5904 break;
5905 case LispDFloat_t:
5906 value = DFLOAT_VALUE(seconds);
5907 break;
5908 default:
5909 break;
5910 }
5911
5912 if (value < 0.0 || value > MOST_POSITIVE_FIXNUM)
5913 LispDestroy("%s: %s is not a positive fixnum",
5914 STRFUN(builtin), STROBJ(seconds));
5915
5916 msec = modf(value, &dsec) * 1e6;
5917 sec = dsec;
5918
5919 if (sec)
5920 sleep(sec);
5921 if (msec)
5922 usleep(msec);
5923
5924 return (NIL);
5925 }
5926
5927 /*
5928 * This function is called recursively, but the contents of "list2" are
5929 * kept gc protected until it returns to LispSort. This is required partly
5930 * because the "gc protection logic" protects an object, not the contents
5931 * of the c pointer.
5932 */
5933 static LispObj *
LispMergeSort(LispObj * list,LispObj * predicate,LispObj * key,int code)5934 LispMergeSort(LispObj *list, LispObj *predicate, LispObj *key, int code)
5935 {
5936 int protect;
5937 LispObj *list1, *list2, *left, *right, *result, *cons;
5938
5939 /* Check if list length is larger than 1 */
5940 if (!CONSP(list) || !CONSP(CDR(list)))
5941 return (list);
5942
5943 list1 = list2 = list;
5944 for (;;) {
5945 list = CDR(list);
5946 if (!CONSP(list))
5947 break;
5948 list = CDR(list);
5949 if (!CONSP(list))
5950 break;
5951 list2 = CDR(list2);
5952 }
5953 cons = list2;
5954 list2 = CDR(list2);
5955 RPLACD(cons, NIL);
5956
5957 protect = 0;
5958 if (lisp__data.protect.length + 2 >= lisp__data.protect.space)
5959 LispMoreProtects();
5960 lisp__data.protect.objects[lisp__data.protect.length++] = list2;
5961 list1 = LispMergeSort(list1, predicate, key, code);
5962 list2 = LispMergeSort(list2, predicate, key, code);
5963
5964 left = CAR(list1);
5965 right = CAR(list2);
5966 if (key != UNSPEC) {
5967 protect = lisp__data.protect.length;
5968 left = APPLY1(key, left);
5969 lisp__data.protect.objects[protect] = left;
5970 right = APPLY1(key, right);
5971 lisp__data.protect.objects[protect + 1] = right;
5972 }
5973
5974 result = NIL;
5975 for (;;) {
5976 if ((FCOMPARE(predicate, left, right, code)) == 0 &&
5977 (FCOMPARE(predicate, right, left, code)) == 1) {
5978 /* right is "smaller" */
5979 if (result == NIL)
5980 result = list2;
5981 else
5982 RPLACD(cons, list2);
5983 cons = list2;
5984 list2 = CDR(list2);
5985 if (!CONSP(list2)) {
5986 RPLACD(cons, list1);
5987 break;
5988 }
5989 right = CAR(list2);
5990 if (key != UNSPEC) {
5991 right = APPLY1(key, right);
5992 lisp__data.protect.objects[protect + 1] = right;
5993 }
5994 }
5995 else {
5996 /* left is "smaller" */
5997 if (result == NIL)
5998 result = list1;
5999 else
6000 RPLACD(cons, list1);
6001 cons = list1;
6002 list1 = CDR(list1);
6003 if (!CONSP(list1)) {
6004 RPLACD(cons, list2);
6005 break;
6006 }
6007 left = CAR(list1);
6008 if (key != UNSPEC) {
6009 left = APPLY1(key, left);
6010 lisp__data.protect.objects[protect] = left;
6011 }
6012 }
6013 }
6014 if (key != UNSPEC)
6015 lisp__data.protect.length = protect;
6016
6017 return (result);
6018 }
6019
6020 /* XXX The first version made a copy of the list and then adjusted
6021 * the CARs of the list. To minimize GC time now it is now doing
6022 * the sort inplace. So, instead of writing just (sort variable)
6023 * now it is required to write (setq variable (sort variable))
6024 * if the variable should always keep all elements.
6025 */
6026 LispObj *
Lisp_Sort(LispBuiltin * builtin)6027 Lisp_Sort(LispBuiltin *builtin)
6028 /*
6029 sort sequence predicate &key key
6030 */
6031 {
6032 GC_ENTER();
6033 int istring, code;
6034 long length;
6035 char *string;
6036
6037 LispObj *list, *work, *cons = NULL;
6038
6039 LispObj *sequence, *predicate, *key;
6040
6041 key = ARGUMENT(2);
6042 predicate = ARGUMENT(1);
6043 sequence = ARGUMENT(0);
6044
6045 length = LispLength(sequence);
6046 if (length < 2)
6047 return (sequence);
6048
6049 list = sequence;
6050 istring = XSTRINGP(sequence);
6051 if (istring) {
6052 CHECK_STRING_WRITABLE(sequence);
6053 /* Convert string to list */
6054 string = THESTR(sequence);
6055 work = cons = CONS(SCHAR(string[0]), NIL);
6056 GC_PROTECT(work);
6057 for (++string; *string; ++string) {
6058 RPLACD(cons, CONS(SCHAR(*string), NIL));
6059 cons = CDR(cons);
6060 }
6061 }
6062 else if (ARRAYP(list))
6063 work = list->data.array.list;
6064 else
6065 work = list;
6066
6067 FUNCTION_CHECK(predicate);
6068 code = FCODE(predicate);
6069 work = LispMergeSort(work, predicate, key, code);
6070
6071 if (istring) {
6072 /* Convert list to string */
6073 string = THESTR(sequence);
6074 for (; CONSP(work); ++string, work = CDR(work))
6075 *string = SCHAR_VALUE(CAR(work));
6076 }
6077 else if (ARRAYP(list))
6078 list->data.array.list = work;
6079 else
6080 sequence = work;
6081 GC_LEAVE();
6082
6083 return (sequence);
6084 }
6085
6086 LispObj *
Lisp_Subseq(LispBuiltin * builtin)6087 Lisp_Subseq(LispBuiltin *builtin)
6088 /*
6089 subseq sequence start &optional end
6090 */
6091 {
6092 long start, end, length, seqlength;
6093
6094 LispObj *sequence, *ostart, *oend, *result;
6095
6096 oend = ARGUMENT(2);
6097 ostart = ARGUMENT(1);
6098 sequence = ARGUMENT(0);
6099
6100 LispCheckSequenceStartEnd(builtin, sequence, ostart, oend,
6101 &start, &end, &length);
6102
6103 seqlength = end - start;
6104
6105 if (sequence == NIL)
6106 result = NIL;
6107 else if (XSTRINGP(sequence)) {
6108 char *string = LispMalloc(seqlength + 1);
6109
6110 memcpy(string, THESTR(sequence) + start, seqlength);
6111 string[seqlength] = '\0';
6112 result = STRING2(string);
6113 }
6114 else {
6115 GC_ENTER();
6116 LispObj *object;
6117
6118 if (end > start) {
6119 /* list or array */
6120 int count;
6121 LispObj *cons;
6122
6123 if (ARRAYP(sequence))
6124 object = sequence->data.array.list;
6125 else
6126 object = sequence;
6127 /* goto first element to copy */
6128 for (count = 0; count < start; count++, object = CDR(object))
6129 ;
6130 result = cons = CONS(CAR(object), NIL);
6131 GC_PROTECT(result);
6132 for (++count, object = CDR(object); count < end; count++,
6133 object = CDR(object)) {
6134 RPLACD(cons, CONS(CAR(object), NIL));
6135 cons = CDR(cons);
6136 }
6137 }
6138 else
6139 result = NIL;
6140
6141 if (ARRAYP(sequence)) {
6142 object = LispNew(NIL, NIL);
6143 GC_PROTECT(object);
6144 object->type = LispArray_t;
6145 object->data.array.list = result;
6146 object->data.array.dim = CONS(FIXNUM(seqlength), NIL);
6147 object->data.array.rank = 1;
6148 object->data.array.type = sequence->data.array.type;
6149 object->data.array.zero = length == 0;
6150 result = object;
6151 }
6152 GC_LEAVE();
6153 }
6154
6155 return (result);
6156 }
6157
6158 LispObj *
Lisp_Subsetp(LispBuiltin * builtin)6159 Lisp_Subsetp(LispBuiltin *builtin)
6160 /*
6161 subsetp list1 list2 &key test test-not key
6162 */
6163 {
6164 return (LispListSet(builtin, SUBSETP));
6165 }
6166
6167
6168 LispObj *
Lisp_Substitute(LispBuiltin * builtin)6169 Lisp_Substitute(LispBuiltin *builtin)
6170 /*
6171 substitute newitem olditem sequence &key from-end test test-not start end count key
6172 */
6173 {
6174 return (LispDeleteRemoveXSubstitute(builtin, SUBSTITUTE, NONE));
6175 }
6176
6177 LispObj *
Lisp_SubstituteIf(LispBuiltin * builtin)6178 Lisp_SubstituteIf(LispBuiltin *builtin)
6179 /*
6180 substitute-if newitem test sequence &key from-end start end count key
6181 */
6182 {
6183 return (LispDeleteRemoveXSubstitute(builtin, SUBSTITUTE, IF));
6184 }
6185
6186 LispObj *
Lisp_SubstituteIfNot(LispBuiltin * builtin)6187 Lisp_SubstituteIfNot(LispBuiltin *builtin)
6188 /*
6189 substitute-if-not newitem test sequence &key from-end start end count key
6190 */
6191 {
6192 return (LispDeleteRemoveXSubstitute(builtin, SUBSTITUTE, IFNOT));
6193 }
6194
6195 LispObj *
Lisp_Symbolp(LispBuiltin * builtin)6196 Lisp_Symbolp(LispBuiltin *builtin)
6197 /*
6198 symbolp object
6199 */
6200 {
6201 LispObj *object;
6202
6203 object = ARGUMENT(0);
6204
6205 return (SYMBOLP(object) ? T : NIL);
6206 }
6207
6208 LispObj *
Lisp_SymbolFunction(LispBuiltin * builtin)6209 Lisp_SymbolFunction(LispBuiltin *builtin)
6210 /*
6211 symbol-function symbol
6212 */
6213 {
6214 LispObj *symbol;
6215
6216 symbol = ARGUMENT(0);
6217 CHECK_SYMBOL(symbol);
6218
6219 return (LispSymbolFunction(symbol));
6220 }
6221
6222 LispObj *
Lisp_SymbolName(LispBuiltin * builtin)6223 Lisp_SymbolName(LispBuiltin *builtin)
6224 /*
6225 symbol-name symbol
6226 */
6227 {
6228 LispObj *symbol;
6229
6230 symbol = ARGUMENT(0);
6231 CHECK_SYMBOL(symbol);
6232
6233 return (LispSymbolName(symbol));
6234 }
6235
6236 LispObj *
Lisp_SymbolPackage(LispBuiltin * builtin)6237 Lisp_SymbolPackage(LispBuiltin *builtin)
6238 /*
6239 symbol-package symbol
6240 */
6241 {
6242 LispObj *symbol;
6243
6244 symbol = ARGUMENT(0);
6245 CHECK_SYMBOL(symbol);
6246
6247 symbol = symbol->data.atom->package;
6248
6249 return (symbol ? symbol : NIL);
6250 }
6251
6252 LispObj *
Lisp_SymbolPlist(LispBuiltin * builtin)6253 Lisp_SymbolPlist(LispBuiltin *builtin)
6254 /*
6255 symbol-plist symbol
6256 */
6257 {
6258 LispObj *symbol;
6259
6260 symbol = ARGUMENT(0);
6261
6262 CHECK_SYMBOL(symbol);
6263
6264 return (symbol->data.atom->a_property ?
6265 symbol->data.atom->property->properties : NIL);
6266 }
6267
6268 LispObj *
Lisp_SymbolValue(LispBuiltin * builtin)6269 Lisp_SymbolValue(LispBuiltin *builtin)
6270 /*
6271 symbol-value symbol
6272 */
6273 {
6274 LispAtom *atom;
6275 LispObj *symbol;
6276
6277 symbol = ARGUMENT(0);
6278
6279 CHECK_SYMBOL(symbol);
6280 atom = symbol->data.atom;
6281 if (!atom->a_object || atom->property->value == UNBOUND) {
6282 if (atom->package == lisp__data.keyword)
6283 return (symbol);
6284 LispDestroy("%s: the symbol %s has no value",
6285 STRFUN(builtin), STROBJ(symbol));
6286 }
6287
6288 return (atom->dyn ? LispGetVar(symbol) : atom->property->value);
6289 }
6290
6291 LispObj *
Lisp_Tagbody(LispBuiltin * builtin)6292 Lisp_Tagbody(LispBuiltin *builtin)
6293 /*
6294 tagbody &rest body
6295 */
6296 {
6297 GC_ENTER();
6298 int stack, lex, length;
6299 LispObj *list, *body, *ptr, *tag, *labels, *map, **p_body;
6300 LispBlock *block;
6301
6302 body = ARGUMENT(0);
6303
6304 /* Save environment information */
6305 stack = lisp__data.stack.length;
6306 lex = lisp__data.env.lex;
6307 length = lisp__data.env.length;
6308
6309 /* Since the body may be large, and the code may iterate several
6310 * thousand times, it is not a bad idea to avoid checking all
6311 * elements of the body to verify if it is a tag. */
6312 for (labels = map = NIL, ptr = body; CONSP(ptr); ptr = CDR(ptr)) {
6313 tag = CAR(ptr);
6314 switch (OBJECT_TYPE(tag)) {
6315 case LispNil_t:
6316 case LispAtom_t:
6317 case LispFixnum_t:
6318 /* Don't allow duplicated labels */
6319 for (list = labels; CONSP(list); list = CDDR(list)) {
6320 if (CAR(list) == tag)
6321 LispDestroy("%s: tag %s specified more than once",
6322 STRFUN(builtin), STROBJ(tag));
6323 }
6324 if (labels == NIL) {
6325 labels = CONS(tag, CONS(NIL, NIL));
6326 map = CDR(labels);
6327 GC_PROTECT(labels);
6328 }
6329 else {
6330 RPLACD(map, CONS(tag, CONS(NIL, NIL)));
6331 map = CDDR(map);
6332 }
6333 break;
6334 case LispCons_t:
6335 /* Restart point for tag */
6336 if (map != NIL && CAR(map) == NIL)
6337 RPLACA(map, ptr);
6338 break;
6339 default:
6340 break;
6341 }
6342 }
6343 /* Check for consecutive labels without code between them */
6344 for (ptr = labels; CONSP(ptr); ptr = CDDR(ptr)) {
6345 if (CADR(ptr) == NIL) {
6346 for (map = CDDR(ptr); CONSP(map); map = CDDR(map)) {
6347 if (CADR(map) != NIL) {
6348 RPLACA(CDR(ptr), CADR(map));
6349 break;
6350 }
6351 }
6352 }
6353 }
6354
6355 /* Initialize */
6356 list = body;
6357 p_body = &body;
6358 block = LispBeginBlock(NIL, LispBlockBody);
6359
6360 /* Loop */
6361 if (setjmp(block->jmp) != 0) {
6362 /* Restore environment */
6363 lisp__data.stack.length = stack;
6364 lisp__data.env.lex = lex;
6365 lisp__data.env.head = lisp__data.env.length = length;
6366
6367 tag = lisp__data.block.block_ret;
6368 for (ptr = labels; CONSP(ptr); ptr = CDDR(ptr)) {
6369 map = CAR(ptr);
6370 if (map == tag)
6371 break;
6372 }
6373
6374 if (!CONSP(ptr))
6375 LispDestroy("%s: no such tag %s", STRFUN(builtin), STROBJ(tag));
6376
6377 *p_body = CADR(ptr);
6378 }
6379
6380 /* Execute code */
6381 for (; CONSP(body); body = CDR(body)) {
6382 LispObj *form = CAR(body);
6383
6384 if (CONSP(form))
6385 EVAL(form);
6386 }
6387 /* If got here, (go) not called, else, labels will be candidate to gc
6388 * when GC_LEAVE() be called by the code in the bottom of the stack. */
6389 GC_LEAVE();
6390
6391 /* Finished */
6392 LispEndBlock(block);
6393
6394 /* Always return NIL */
6395 return (NIL);
6396 }
6397
6398 LispObj *
Lisp_The(LispBuiltin * builtin)6399 Lisp_The(LispBuiltin *builtin)
6400 /*
6401 the value-type form
6402 */
6403 {
6404 LispObj *value_type, *form;
6405
6406 form = ARGUMENT(1);
6407 value_type = ARGUMENT(0);
6408
6409 form = EVAL(form);
6410
6411 return (LispCoerce(builtin, form, value_type));
6412 }
6413
6414 LispObj *
Lisp_Throw(LispBuiltin * builtin)6415 Lisp_Throw(LispBuiltin *builtin)
6416 /*
6417 throw tag result
6418 */
6419 {
6420 unsigned blevel = lisp__data.block.block_level;
6421
6422 LispObj *tag, *result;
6423
6424 result = ARGUMENT(1);
6425 tag = ARGUMENT(0);
6426
6427 tag = EVAL(tag);
6428
6429 if (blevel == 0)
6430 LispDestroy("%s: not within a block", STRFUN(builtin));
6431
6432 while (blevel) {
6433 LispBlock *block = lisp__data.block.block[--blevel];
6434
6435 if (block->type == LispBlockCatch && tag == block->tag) {
6436 lisp__data.block.block_ret = EVAL(result);
6437 LispBlockUnwind(block);
6438 BLOCKJUMP(block);
6439 }
6440 }
6441 LispDestroy("%s: %s is not a valid tag", STRFUN(builtin), STROBJ(tag));
6442
6443 /*NOTREACHED*/
6444 return (NIL);
6445 }
6446
6447 static LispObj *
LispTreeEqual(LispObj * left,LispObj * right,LispObj * test,int expect)6448 LispTreeEqual(LispObj *left, LispObj *right, LispObj *test, int expect)
6449 {
6450 LispObj *cmp_left, *cmp_right;
6451
6452 if ((OBJECT_TYPE(left)) ^ (OBJECT_TYPE(right)))
6453 return (NIL);
6454 if (CONSP(left)) {
6455 for (; CONSP(left) && CONSP(right);
6456 left = CDR(left), right = CDR(right)) {
6457 cmp_left = CAR(left);
6458 cmp_right = CAR(right);
6459 if ((OBJECT_TYPE(cmp_left)) ^ (OBJECT_TYPE(cmp_right)))
6460 return (NIL);
6461 if (CONSP(cmp_left)) {
6462 if (LispTreeEqual(cmp_left, cmp_right, test, expect) == NIL)
6463 return (NIL);
6464 }
6465 else {
6466 if (POINTERP(cmp_left) &&
6467 (XQUOTEP(cmp_left) || XBACKQUOTEP(cmp_left))) {
6468 cmp_left = cmp_left->data.quote;
6469 cmp_right = cmp_right->data.quote;
6470 }
6471 else if (COMMAP(cmp_left)) {
6472 cmp_left = cmp_left->data.comma.eval;
6473 cmp_right = cmp_right->data.comma.eval;
6474 }
6475 if ((APPLY2(test, cmp_left, cmp_right) != NIL) != expect)
6476 return (NIL);
6477 }
6478 }
6479 if ((OBJECT_TYPE(left)) ^ (OBJECT_TYPE(right)))
6480 return (NIL);
6481 }
6482
6483 if (POINTERP(left) && (XQUOTEP(left) || XBACKQUOTEP(left))) {
6484 left = left->data.quote;
6485 right = right->data.quote;
6486 }
6487 else if (COMMAP(left)) {
6488 left = left->data.comma.eval;
6489 right = right->data.comma.eval;
6490 }
6491
6492 return ((APPLY2(test, left, right) != NIL) == expect ? T : NIL);
6493 }
6494
6495 LispObj *
Lisp_TreeEqual(LispBuiltin * builtin)6496 Lisp_TreeEqual(LispBuiltin *builtin)
6497 /*
6498 tree-equal tree-1 tree-2 &key test test-not
6499 */
6500 {
6501 int expect;
6502 LispObj *compare;
6503
6504 LispObj *tree_1, *tree_2, *test, *test_not;
6505
6506 test_not = ARGUMENT(3);
6507 test = ARGUMENT(2);
6508 tree_2 = ARGUMENT(1);
6509 tree_1 = ARGUMENT(0);
6510
6511 CHECK_TEST_0();
6512 if (test_not != UNSPEC) {
6513 expect = 0;
6514 compare = test_not;
6515 }
6516 else {
6517 if (test == UNSPEC)
6518 test = Oeql;
6519 expect = 1;
6520 compare = test;
6521 }
6522
6523 return (LispTreeEqual(tree_1, tree_2, compare, expect));
6524 }
6525
6526 LispObj *
Lisp_Typep(LispBuiltin * builtin)6527 Lisp_Typep(LispBuiltin *builtin)
6528 /*
6529 typep object type
6530 */
6531 {
6532 LispObj *result = NULL;
6533
6534 LispObj *object, *type;
6535
6536 type = ARGUMENT(1);
6537 object = ARGUMENT(0);
6538
6539 if (SYMBOLP(type)) {
6540 Atom_id atom = ATOMID(type);
6541
6542 if (OBJECT_TYPE(object) == LispStruct_t)
6543 result = ATOMID(CAR(object->data.struc.def)) == atom ? T : NIL;
6544 else if (type->data.atom->a_defstruct &&
6545 type->data.atom->property->structure.function == STRUCT_NAME)
6546 result = NIL;
6547 else if (atom == Snil)
6548 result = object == NIL ? T : NIL;
6549 else if (atom == St)
6550 result = object == T ? T : NIL;
6551 else if (atom == Satom)
6552 result = !CONSP(object) ? T : NIL;
6553 else if (atom == Ssymbol)
6554 result = SYMBOLP(object) || object == NIL || object == T ? T : NIL;
6555 else if (atom == Sinteger)
6556 result = INTEGERP(object) ? T : NIL;
6557 else if (atom == Srational)
6558 result = RATIONALP(object) ? T : NIL;
6559 else if (atom == Scons || atom == Slist)
6560 result = CONSP(object) ? T : NIL;
6561 else if (atom == Sstring)
6562 result = STRINGP(object) ? T : NIL;
6563 else if (atom == Scharacter)
6564 result = SCHARP(object) ? T : NIL;
6565 else if (atom == Scomplex)
6566 result = COMPLEXP(object) ? T : NIL;
6567 else if (atom == Svector || atom == Sarray)
6568 result = ARRAYP(object) ? T : NIL;
6569 else if (atom == Skeyword)
6570 result = KEYWORDP(object) ? T : NIL;
6571 else if (atom == Sfunction)
6572 result = LAMBDAP(object) ? T : NIL;
6573 else if (atom == Spathname)
6574 result = PATHNAMEP(object) ? T : NIL;
6575 else if (atom == Sopaque)
6576 result = OPAQUEP(object) ? T : NIL;
6577 }
6578 else if (CONSP(type)) {
6579 if (OBJECT_TYPE(object) == LispStruct_t &&
6580 SYMBOLP(CAR(type)) && ATOMID(CAR(type)) == Sstruct &&
6581 SYMBOLP(CAR(CDR(type))) && CDR(CDR(type)) == NIL) {
6582 result = ATOMID(CAR(object->data.struc.def)) ==
6583 ATOMID(CAR(CDR(type))) ? T : NIL;
6584 }
6585 }
6586 else if (type == NIL)
6587 result = object == NIL ? T : NIL;
6588 else if (type == T)
6589 result = object == T ? T : NIL;
6590 if (result == NULL)
6591 LispDestroy("%s: bad type specification %s",
6592 STRFUN(builtin), STROBJ(type));
6593
6594 return (result);
6595 }
6596
6597 LispObj *
Lisp_Union(LispBuiltin * builtin)6598 Lisp_Union(LispBuiltin *builtin)
6599 /*
6600 union list1 list2 &key test test-not key
6601 */
6602 {
6603 return (LispListSet(builtin, UNION));
6604 }
6605
6606 LispObj *
Lisp_Nunion(LispBuiltin * builtin)6607 Lisp_Nunion(LispBuiltin *builtin)
6608 /*
6609 nunion list1 list2 &key test test-not key
6610 */
6611 {
6612 return (LispListSet(builtin, NUNION));
6613 }
6614
6615 LispObj *
Lisp_Unless(LispBuiltin * builtin)6616 Lisp_Unless(LispBuiltin *builtin)
6617 /*
6618 unless test &rest body
6619 */
6620 {
6621 LispObj *result, *test, *body;
6622
6623 body = ARGUMENT(1);
6624 test = ARGUMENT(0);
6625
6626 result = NIL;
6627 test = EVAL(test);
6628 RETURN_COUNT = 0;
6629 if (test == NIL) {
6630 for (; CONSP(body); body = CDR(body))
6631 result = EVAL(CAR(body));
6632 }
6633
6634 return (result);
6635 }
6636
6637 /*
6638 * ext::until
6639 */
6640 LispObj *
Lisp_Until(LispBuiltin * builtin)6641 Lisp_Until(LispBuiltin *builtin)
6642 /*
6643 until test &rest body
6644 */
6645 {
6646 LispObj *result, *test, *body, *prog;
6647
6648 body = ARGUMENT(1);
6649 test = ARGUMENT(0);
6650
6651 result = NIL;
6652 for (;;) {
6653 if ((result = EVAL(test)) == NIL) {
6654 for (prog = body; CONSP(prog); prog = CDR(prog))
6655 (void)EVAL(CAR(prog));
6656 }
6657 else
6658 break;
6659 }
6660
6661 return (result);
6662 }
6663
6664 LispObj *
Lisp_UnwindProtect(LispBuiltin * builtin)6665 Lisp_UnwindProtect(LispBuiltin *builtin)
6666 /*
6667 unwind-protect protect &rest cleanup
6668 */
6669 {
6670 LispObj *result, **presult = &result;
6671 int did_jump, *pdid_jump = &did_jump, destroyed;
6672 LispBlock *block;
6673
6674 LispObj *protect, *cleanup, **pcleanup = &cleanup;
6675
6676 cleanup = ARGUMENT(1);
6677 protect = ARGUMENT(0);
6678
6679 /* run protected code */
6680 *presult = NIL;
6681 *pdid_jump = 1;
6682 block = LispBeginBlock(NIL, LispBlockProtect);
6683 if (setjmp(block->jmp) == 0) {
6684 *presult = EVAL(protect);
6685 *pdid_jump = 0;
6686 }
6687 LispEndBlock(block);
6688 if (!lisp__data.destroyed && *pdid_jump)
6689 *presult = lisp__data.block.block_ret;
6690
6691 destroyed = lisp__data.destroyed;
6692 lisp__data.destroyed = 0;
6693
6694 /* run cleanup, unprotected code */
6695 if (CONSP(*pcleanup))
6696 for (; CONSP(cleanup); cleanup = CDR(cleanup))
6697 (void)EVAL(CAR(cleanup));
6698
6699 if (destroyed) {
6700 /* in case there is another unwind-protect */
6701 LispBlockUnwind(NULL);
6702 /* if not, just return to the toplevel */
6703 lisp__data.destroyed = 1;
6704 LispDestroy(".");
6705 }
6706
6707 return (result);
6708 }
6709
6710 static LispObj *
LispValuesList(LispBuiltin * builtin,int check_list)6711 LispValuesList(LispBuiltin *builtin, int check_list)
6712 {
6713 long i, count;
6714 LispObj *result;
6715
6716 LispObj *list;
6717
6718 list = ARGUMENT(0);
6719
6720 count = LispLength(list) - 1;
6721
6722 if (count >= 0) {
6723 result = CAR(list);
6724 if ((RETURN_CHECK(count)) != count)
6725 LispDestroy("%s: too many values", STRFUN(builtin));
6726 RETURN_COUNT = count;
6727 for (i = 0, list = CDR(list); count && CONSP(list);
6728 count--, i++, list = CDR(list))
6729 RETURN(i) = CAR(list);
6730 if (check_list) {
6731 CHECK_LIST(list);
6732 }
6733 }
6734 else {
6735 RETURN_COUNT = -1;
6736 result = NIL;
6737 }
6738
6739 return (result);
6740 }
6741
6742 LispObj *
Lisp_Values(LispBuiltin * builtin)6743 Lisp_Values(LispBuiltin *builtin)
6744 /*
6745 values &rest objects
6746 */
6747 {
6748 return (LispValuesList(builtin, 0));
6749 }
6750
6751 LispObj *
Lisp_ValuesList(LispBuiltin * builtin)6752 Lisp_ValuesList(LispBuiltin *builtin)
6753 /*
6754 values-list list
6755 */
6756 {
6757 return (LispValuesList(builtin, 1));
6758 }
6759
6760 LispObj *
Lisp_Vector(LispBuiltin * builtin)6761 Lisp_Vector(LispBuiltin *builtin)
6762 /*
6763 vector &rest objects
6764 */
6765 {
6766 LispObj *objects;
6767
6768 objects = ARGUMENT(0);
6769
6770 return (VECTOR(objects));
6771 }
6772
6773 LispObj *
Lisp_When(LispBuiltin * builtin)6774 Lisp_When(LispBuiltin *builtin)
6775 /*
6776 when test &rest body
6777 */
6778 {
6779 LispObj *result, *test, *body;
6780
6781 body = ARGUMENT(1);
6782 test = ARGUMENT(0);
6783
6784 result = NIL;
6785 test = EVAL(test);
6786 RETURN_COUNT = 0;
6787 if (test != NIL) {
6788 for (; CONSP(body); body = CDR(body))
6789 result = EVAL(CAR(body));
6790 }
6791
6792 return (result);
6793 }
6794
6795 /*
6796 * ext::while
6797 */
6798 LispObj *
Lisp_While(LispBuiltin * builtin)6799 Lisp_While(LispBuiltin *builtin)
6800 /*
6801 while test &rest body
6802 */
6803 {
6804 LispObj *test, *body, *prog;
6805
6806 body = ARGUMENT(1);
6807 test = ARGUMENT(0);
6808
6809 for (;;) {
6810 if (EVAL(test) != NIL) {
6811 for (prog = body; CONSP(prog); prog = CDR(prog))
6812 (void)EVAL(CAR(prog));
6813 }
6814 else
6815 break;
6816 }
6817
6818 return (NIL);
6819 }
6820
6821 /*
6822 * ext::unsetenv
6823 */
6824 LispObj *
Lisp_Unsetenv(LispBuiltin * builtin)6825 Lisp_Unsetenv(LispBuiltin *builtin)
6826 /*
6827 unsetenv name
6828 */
6829 {
6830 char *name;
6831
6832 LispObj *oname;
6833
6834 oname = ARGUMENT(0);
6835
6836 CHECK_STRING(oname);
6837 name = THESTR(oname);
6838
6839 unsetenv(name);
6840
6841 return (NIL);
6842 }
6843
6844 LispObj *
Lisp_XeditEltStore(LispBuiltin * builtin)6845 Lisp_XeditEltStore(LispBuiltin *builtin)
6846 /*
6847 lisp::elt-store sequence index value
6848 */
6849 {
6850 int length, offset;
6851
6852 LispObj *sequence, *oindex, *value;
6853
6854 value = ARGUMENT(2);
6855 oindex = ARGUMENT(1);
6856 sequence = ARGUMENT(0);
6857
6858 CHECK_INDEX(oindex);
6859 offset = FIXNUM_VALUE(oindex);
6860 length = LispLength(sequence);
6861
6862 if (offset >= length)
6863 LispDestroy("%s: index %d too large for sequence length %d",
6864 STRFUN(builtin), offset, length);
6865
6866 if (STRINGP(sequence)) {
6867 int ch;
6868
6869 CHECK_STRING_WRITABLE(sequence);
6870 CHECK_SCHAR(value);
6871 ch = SCHAR_VALUE(value);
6872 if (ch < 0 || ch > 255)
6873 LispDestroy("%s: cannot represent character %d",
6874 STRFUN(builtin), ch);
6875 THESTR(sequence)[offset] = ch;
6876 }
6877 else {
6878 if (ARRAYP(sequence))
6879 sequence = sequence->data.array.list;
6880
6881 for (; offset > 0; offset--, sequence = CDR(sequence))
6882 ;
6883 RPLACA(sequence, value);
6884 }
6885
6886 return (value);
6887 }
6888
6889 LispObj *
Lisp_XeditPut(LispBuiltin * builtin)6890 Lisp_XeditPut(LispBuiltin *builtin)
6891 /*
6892 lisp::put symbol indicator value
6893 */
6894 {
6895 LispObj *symbol, *indicator, *value;
6896
6897 value = ARGUMENT(2);
6898 indicator = ARGUMENT(1);
6899 symbol = ARGUMENT(0);
6900
6901 CHECK_SYMBOL(symbol);
6902
6903 return (CAR(LispPutAtomProperty(symbol->data.atom, indicator, value)));
6904 }
6905
6906 LispObj *
Lisp_XeditSetSymbolPlist(LispBuiltin * builtin)6907 Lisp_XeditSetSymbolPlist(LispBuiltin *builtin)
6908 /*
6909 lisp::set-symbol-plist symbol list
6910 */
6911 {
6912 LispObj *symbol, *list;
6913
6914 list = ARGUMENT(1);
6915 symbol = ARGUMENT(0);
6916
6917 CHECK_SYMBOL(symbol);
6918
6919 return (LispReplaceAtomPropertyList(symbol->data.atom, list));
6920 }
6921
6922 LispObj *
Lisp_XeditVectorStore(LispBuiltin * builtin)6923 Lisp_XeditVectorStore(LispBuiltin *builtin)
6924 /*
6925 lisp::vector-store array &rest values
6926 */
6927 {
6928 LispObj *value, *list, *object;
6929 long rank, count, sequence, offset, accum;
6930
6931 LispObj *array, *values;
6932
6933 values = ARGUMENT(1);
6934 array = ARGUMENT(0);
6935
6936 /* check for errors */
6937 for (rank = 0, list = values;
6938 CONSP(list) && CONSP(CDR(list));
6939 list = CDR(list), rank++) {
6940 CHECK_INDEX(CAR(values));
6941 }
6942
6943 if (rank == 0)
6944 LispDestroy("%s: too few subscripts", STRFUN(builtin));
6945 value = CAR(list);
6946
6947 if (STRINGP(array) && rank == 1) {
6948 long ch;
6949 long length = STRLEN(array);
6950 long offset = FIXNUM_VALUE(CAR(values));
6951
6952 CHECK_SCHAR(value);
6953 CHECK_STRING_WRITABLE(array);
6954 ch = SCHAR_VALUE(value);
6955 if (offset >= length)
6956 LispDestroy("%s: index %ld too large for sequence length %ld",
6957 STRFUN(builtin), offset, length);
6958
6959 if (ch < 0 || ch > 255)
6960 LispDestroy("%s: cannot represent character %ld",
6961 STRFUN(builtin), ch);
6962 THESTR(array)[offset] = ch;
6963
6964 return (value);
6965 }
6966
6967 CHECK_ARRAY(array);
6968 if (rank != array->data.array.rank)
6969 LispDestroy("%s: too %s subscripts", STRFUN(builtin),
6970 rank < array->data.array.rank ? "few" : "many");
6971
6972 for (list = values, object = array->data.array.dim;
6973 CONSP(CDR(list));
6974 list = CDR(list), object = CDR(object)) {
6975 if (FIXNUM_VALUE(CAR(list)) >= FIXNUM_VALUE(CAR(object)))
6976 LispDestroy("%s: %ld is out of range, index %ld",
6977 STRFUN(builtin),
6978 FIXNUM_VALUE(CAR(list)),
6979 FIXNUM_VALUE(CAR(object)));
6980 }
6981
6982 for (count = sequence = 0, list = values;
6983 CONSP(CDR(list));
6984 list = CDR(list), sequence++) {
6985 for (offset = 0, object = array->data.array.dim;
6986 offset < sequence; object = CDR(object), offset++)
6987 ;
6988 for (accum = 1, object = CDR(object); CONSP(object);
6989 object = CDR(object))
6990 accum *= FIXNUM_VALUE(CAR(object));
6991 count += accum * FIXNUM_VALUE(CAR(list));
6992 }
6993
6994 for (array = array->data.array.list; count > 0; array = CDR(array), count--)
6995 ;
6996
6997 RPLACA(array, value);
6998
6999 return (value);
7000 }
7001
7002 LispObj *
Lisp_XeditDocumentationStore(LispBuiltin * builtin)7003 Lisp_XeditDocumentationStore(LispBuiltin *builtin)
7004 /*
7005 lisp::documentation-store symbol type string
7006 */
7007 {
7008 LispDocType_t doc_type;
7009
7010 LispObj *symbol, *type, *string;
7011
7012 string = ARGUMENT(2);
7013 type = ARGUMENT(1);
7014 symbol = ARGUMENT(0);
7015
7016 CHECK_SYMBOL(symbol);
7017
7018 /* type is checked in LispDocumentationType() */
7019 doc_type = LispDocumentationType(builtin, type);
7020
7021 if (string == NIL)
7022 /* allow explicitly releasing memory used for documentation */
7023 LispRemDocumentation(symbol, doc_type);
7024 else {
7025 CHECK_STRING(string);
7026 LispAddDocumentation(symbol, string, doc_type);
7027 }
7028
7029 return (string);
7030 }
7031