core.c revision 31de2854 
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 */
43typedef 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
70extern int setenv(const char *name, const char *value, int overwrite);
71extern 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
149static LispObj *LispAdjoin(LispBuiltin*,
150			   LispObj*, LispObj*, LispObj*, LispObj*, LispObj*);
151static LispObj *LispAssocOrMember(LispBuiltin*, int, int);
152static LispObj *LispEverySomeAnyNot(LispBuiltin*, int);
153static LispObj *LispFindOrPosition(LispBuiltin*, int, int);
154static LispObj *LispDeleteOrRemoveDuplicates(LispBuiltin*, int);
155static LispObj *LispDeleteRemoveXSubstitute(LispBuiltin*, int, int);
156static LispObj *LispListSet(LispBuiltin*, int);
157static LispObj *LispMapc(LispBuiltin*, int);
158static LispObj *LispMapl(LispBuiltin*, int);
159static LispObj *LispMapnconc(LispObj*);
160extern LispObj *LispRunSetf(LispArgList*, LispObj*, LispObj*, LispObj*);
161extern LispObj *LispRunSetfMacro(LispAtom*, LispObj*, LispObj*);
162static LispObj *LispMergeSort(LispObj*, LispObj*, LispObj*, int);
163static LispObj *LispXReverse(LispBuiltin*, int);
164static LispObj *LispCopyList(LispBuiltin*, LispObj*, int);
165static LispObj *LispValuesList(LispBuiltin*, int);
166static LispObj *LispTreeEqual(LispObj*, LispObj*, LispObj*, int);
167static LispDocType_t LispDocumentationType(LispBuiltin*, LispObj*);
168
169extern void LispSetAtomObjectProperty(LispAtom*, LispObj*);
170
171/*
172 * Initialization
173 */
174LispObj *Oeq, *Oeql, *Oequal, *Oequalp, *Omake_array,
175	*Kinitial_contents, *Osetf, *Ootherwise, *Oquote;
176LispObj *Ogensym_counter;
177
178Atom_id Svariable, Sstructure, Stype, Ssetf;
179
180/*
181 * Implementation
182 */
183void
184LispCoreInit(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
210LispObj *
211Lisp_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
225static LispObj *
226LispAdjoin(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
267LispObj *
268Lisp_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
284LispObj *
285Lisp_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
341LispObj *
342Lisp_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
400static LispObj *
401LispAssocOrMember(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
472LispObj *
473Lisp_Assoc(LispBuiltin *builtin)
474/*
475 assoc item list &key test test-not key
476 */
477{
478    return (LispAssocOrMember(builtin, ASSOC, NONE));
479}
480
481LispObj *
482Lisp_AssocIf(LispBuiltin *builtin)
483/*
484 assoc-if predicate list &key key
485 */
486{
487    return (LispAssocOrMember(builtin, ASSOC, IF));
488}
489
490LispObj *
491Lisp_AssocIfNot(LispBuiltin *builtin)
492/*
493 assoc-if-not predicate list &key key
494 */
495{
496    return (LispAssocOrMember(builtin, ASSOC, IFNOT));
497}
498
499LispObj *
500Lisp_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
518LispObj *
519Lisp_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
567LispObj *
568Lisp_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
580LispObj *
581Lisp_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
614LispObj *
615Lisp_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
634LispObj *
635Lisp_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
673LispObj *
674Lisp_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
708LispObj *
709Lisp_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
728LispObj *
729Lisp_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
775LispObj *
776Lisp_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
805LispObj *
806Lisp_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
819LispObj *
820Lisp_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
839LispObj *
840Lisp_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
866LispObj *
867Lisp_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
892static LispObj *
893LispCopyList(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
946LispObj *
947Lisp_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
959LispObj *
960Lisp_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
972LispObj *
973Lisp_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
985LispObj *
986Lisp_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
999LispObj *
1000Lisp_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
1012LispObj *
1013Lisp_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
1035LispObj *
1036Lisp_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
1058LispObj *
1059Lisp_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
1101LispObj *
1102Lisp_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
1143LispObj *
1144Lisp_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
1194LispObj *
1195Lisp_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
1218LispObj *
1219Lisp_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
1244LispObj *
1245Lisp_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
1253LispObj *
1254Lisp_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
1262LispObj *
1263Lisp_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
1271LispObj *
1272Lisp_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
1280LispObj *
1281Lisp_Do(LispBuiltin *builtin)
1282/*
1283 do init test &rest body
1284 */
1285{
1286    return (LispDo(builtin, 0));
1287}
1288
1289LispObj *
1290Lisp_DoP(LispBuiltin *builtin)
1291/*
1292 do* init test &rest body
1293 */
1294{
1295    return (LispDo(builtin, 1));
1296}
1297
1298static LispDocType_t
1299LispDocumentationType(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
1326LispObj *
1327Lisp_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
1343LispObj *
1344Lisp_DoList(LispBuiltin *builtin)
1345{
1346    return (LispDoListTimes(builtin, 0));
1347}
1348
1349LispObj *
1350Lisp_DoTimes(LispBuiltin *builtin)
1351{
1352    return (LispDoListTimes(builtin, 1));
1353}
1354
1355LispObj *
1356Lisp_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
1391LispObj *
1392Lisp_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
1408LispObj *
1409Lisp_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
1422LispObj *
1423Lisp_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
1436LispObj *
1437Lisp_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
1450LispObj *
1451Lisp_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
1464LispObj *
1465Lisp_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
1487LispObj *
1488Lisp_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
1507static LispObj *
1508LispEverySomeAnyNot(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
1608LispObj *
1609Lisp_Every(LispBuiltin *builtin)
1610/*
1611 every predicate sequence &rest more-sequences
1612 */
1613{
1614    return (LispEverySomeAnyNot(builtin, EVERY));
1615}
1616
1617LispObj *
1618Lisp_Some(LispBuiltin *builtin)
1619/*
1620 some predicate sequence &rest more-sequences
1621 */
1622{
1623    return (LispEverySomeAnyNot(builtin, SOME));
1624}
1625
1626LispObj *
1627Lisp_Notevery(LispBuiltin *builtin)
1628/*
1629 notevery predicate sequence &rest more-sequences
1630 */
1631{
1632    return (LispEverySomeAnyNot(builtin, NOTEVERY));
1633}
1634
1635LispObj *
1636Lisp_Notany(LispBuiltin *builtin)
1637/*
1638 notany predicate sequence &rest more-sequences
1639 */
1640{
1641    return (LispEverySomeAnyNot(builtin, NOTANY));
1642}
1643
1644LispObj *
1645Lisp_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
1663LispObj *
1664Lisp_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
1672LispObj *
1673Lisp_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
1681LispObj *
1682Lisp_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
1690LispObj *
1691Lisp_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
1735LispObj *
1736Lisp_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
1756LispObj *
1757Lisp_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
1774LispObj *
1775Lisp_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
1787LispObj *
1788Lisp_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 */
1816LispObj *
1817Lisp_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
1834LispObj *
1835Lisp_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
1850LispObj *
1851Lisp_Gensym(LispBuiltin *builtin)
1852/*
1853 gensym &optional arg
1854 */
1855{
1856    char *preffix = "G", name[132];
1857    long counter = LONGINT_VALUE(Ogensym_counter->data.atom->property->value);
1858    LispObj *symbol;
1859
1860    LispObj *arg;
1861
1862    arg = ARGUMENT(0);
1863    if (arg != UNSPEC) {
1864	if (STRINGP(arg))
1865	    preffix = THESTR(arg);
1866	else {
1867	    CHECK_INDEX(arg);
1868	    counter = FIXNUM_VALUE(arg);
1869	}
1870    }
1871    snprintf(name, sizeof(name), "%s%ld", preffix, counter);
1872    if (strlen(name) >= 128)
1873	LispDestroy("%s: name %s too long", STRFUN(builtin), name);
1874    Ogensym_counter->data.atom->property->value = INTEGER(counter + 1);
1875
1876    symbol = UNINTERNED_ATOM(name);
1877    symbol->data.atom->unreadable = !LispCheckAtomString(name);
1878
1879    return (symbol);
1880}
1881
1882LispObj *
1883Lisp_Go(LispBuiltin *builtin)
1884/*
1885 go tag
1886 */
1887{
1888    unsigned blevel = lisp__data.block.block_level;
1889
1890    LispObj *tag;
1891
1892    tag = ARGUMENT(0);
1893
1894    while (blevel) {
1895	LispBlock *block = lisp__data.block.block[--blevel];
1896
1897	if (block->type == LispBlockClosure)
1898	    /* if reached a function call */
1899	    break;
1900	if (block->type == LispBlockBody) {
1901	    lisp__data.block.block_ret = tag;
1902	    LispBlockUnwind(block);
1903	    BLOCKJUMP(block);
1904	}
1905     }
1906
1907    LispDestroy("%s: no visible tagbody for %s",
1908		STRFUN(builtin), STROBJ(tag));
1909    /*NOTREACHED*/
1910    return (NIL);
1911}
1912
1913LispObj *
1914Lisp_If(LispBuiltin *builtin)
1915/*
1916 if test then &optional else
1917 */
1918{
1919    LispObj *result, *test, *then, *oelse;
1920
1921    oelse = ARGUMENT(2);
1922    then = ARGUMENT(1);
1923    test = ARGUMENT(0);
1924
1925    test = EVAL(test);
1926    if (test != NIL)
1927	result = EVAL(then);
1928    else if (oelse != UNSPEC)
1929	result = EVAL(oelse);
1930    else
1931	result = NIL;
1932
1933    return (result);
1934}
1935
1936LispObj *
1937Lisp_IgnoreErrors(LispBuiltin *builtin)
1938/*
1939 ignore-erros &rest body
1940 */
1941{
1942    LispObj *result;
1943    int i, jumped;
1944    LispBlock *block;
1945
1946    /* interpreter state */
1947    GC_ENTER();
1948    int stack, lex, length;
1949
1950    /* memory allocation */
1951    int mem_level;
1952    void **mem;
1953
1954    LispObj *body;
1955
1956    body = ARGUMENT(0);
1957
1958    /* Save environment information */
1959    stack = lisp__data.stack.length;
1960    lex = lisp__data.env.lex;
1961    length = lisp__data.env.length;
1962
1963    /* Save memory allocation information */
1964    mem_level = lisp__data.mem.level;
1965    mem = LispMalloc(mem_level * sizeof(void*));
1966    memcpy(mem, lisp__data.mem.mem, mem_level * sizeof(void*));
1967
1968    ++lisp__data.ignore_errors;
1969    result = NIL;
1970    jumped = 1;
1971    block = LispBeginBlock(NIL, LispBlockProtect);
1972    if (setjmp(block->jmp) == 0) {
1973	for (; CONSP(body); body = CDR(body))
1974	    result = EVAL(CAR(body));
1975	jumped = 0;
1976    }
1977    LispEndBlock(block);
1978    if (!lisp__data.destroyed && jumped)
1979	result = lisp__data.block.block_ret;
1980
1981    if (lisp__data.destroyed) {
1982	/* Restore environment */
1983	lisp__data.stack.length = stack;
1984	lisp__data.env.lex = lex;
1985	lisp__data.env.head = lisp__data.env.length = length;
1986	GC_LEAVE();
1987
1988	/* Check for possible leaks due to ignoring errors */
1989	for (i = 0; i < mem_level; i++) {
1990	    if (lisp__data.mem.mem[i] && mem[i] != lisp__data.mem.mem[i])
1991		LispFree(lisp__data.mem.mem[i]);
1992	}
1993	for (; i < lisp__data.mem.level; i++) {
1994	    if (lisp__data.mem.mem[i])
1995		LispFree(lisp__data.mem.mem[i]);
1996	}
1997
1998	lisp__data.destroyed = 0;
1999	result = NIL;
2000	RETURN_COUNT = 1;
2001	RETURN(0) = lisp__data.error_condition;
2002    }
2003    LispFree(mem);
2004    --lisp__data.ignore_errors;
2005
2006    return (result);
2007}
2008
2009LispObj *
2010Lisp_Intersection(LispBuiltin *builtin)
2011/*
2012 intersection list1 list2 &key test test-not key
2013 */
2014{
2015    return (LispListSet(builtin, INTERSECTION));
2016}
2017
2018LispObj *
2019Lisp_Nintersection(LispBuiltin *builtin)
2020/*
2021 nintersection list1 list2 &key test test-not key
2022 */
2023{
2024    return (LispListSet(builtin, NINTERSECTION));
2025}
2026
2027LispObj *
2028Lisp_Keywordp(LispBuiltin *builtin)
2029/*
2030 keywordp object
2031 */
2032{
2033    LispObj *object;
2034
2035    object = ARGUMENT(0);
2036
2037    return (KEYWORDP(object) ? T : NIL);
2038}
2039
2040LispObj *
2041Lisp_Lambda(LispBuiltin *builtin)
2042/*
2043 lambda lambda-list &rest body
2044 */
2045{
2046    GC_ENTER();
2047    LispObj *name;
2048    LispArgList *alist;
2049
2050    LispObj *lambda, *lambda_list, *body;
2051
2052    body = ARGUMENT(1);
2053    lambda_list = ARGUMENT(0);
2054
2055    alist = LispCheckArguments(LispLambda, lambda_list, Snil->value, 0);
2056
2057    name = OPAQUE(alist, LispArgList_t);
2058    lambda_list = LispListProtectedArguments(alist);
2059    GC_PROTECT(name);
2060    GC_PROTECT(lambda_list);
2061    lambda = LispNewLambda(name, body, lambda_list, LispLambda);
2062    LispUseArgList(alist);
2063    GC_LEAVE();
2064
2065    return (lambda);
2066}
2067
2068LispObj *
2069Lisp_Last(LispBuiltin *builtin)
2070/*
2071 last list &optional count
2072 */
2073{
2074    long count, length;
2075    LispObj *list, *ocount;
2076
2077    ocount = ARGUMENT(1);
2078    list = ARGUMENT(0);
2079
2080    if (!CONSP(list))
2081	return (list);
2082
2083    length = LispLength(list);
2084
2085    if (ocount == UNSPEC)
2086	count = 1;
2087    else {
2088	CHECK_INDEX(ocount);
2089	count = FIXNUM_VALUE(ocount);
2090    }
2091
2092    if (count >= length)
2093	return (list);
2094
2095    length -= count;
2096    for (; length > 0; length--)
2097	list = CDR(list);
2098
2099    return (list);
2100}
2101
2102LispObj *
2103Lisp_Length(LispBuiltin *builtin)
2104/*
2105 length sequence
2106 */
2107{
2108    LispObj *sequence;
2109
2110    sequence = ARGUMENT(0);
2111
2112    return (FIXNUM(LispLength(sequence)));
2113}
2114
2115LispObj *
2116Lisp_Let(LispBuiltin *builtin)
2117/*
2118 let init &rest body
2119 */
2120{
2121    GC_ENTER();
2122    int head = lisp__data.env.length;
2123    LispObj *init, *body, *pair, *result, *list, *cons = NIL;
2124
2125    body = ARGUMENT(1);
2126    init = ARGUMENT(0);
2127
2128    CHECK_LIST(init);
2129    for (list = NIL; CONSP(init); init = CDR(init)) {
2130	LispObj *symbol, *value;
2131
2132	pair = CAR(init);
2133	if (SYMBOLP(pair)) {
2134	    symbol = pair;
2135	    value = NIL;
2136	}
2137	else {
2138	    CHECK_CONS(pair);
2139	    symbol = CAR(pair);
2140	    CHECK_SYMBOL(symbol);
2141	    pair = CDR(pair);
2142	    if (CONSP(pair)) {
2143		value = CAR(pair);
2144		if (CDR(pair) != NIL)
2145		    LispDestroy("%s: too much arguments to initialize %s",
2146				STRFUN(builtin), STROBJ(symbol));
2147		value = EVAL(value);
2148	    }
2149	    else
2150		value = NIL;
2151	}
2152	pair = CONS(symbol, value);
2153	if (list == NIL) {
2154	    list = cons = CONS(pair, NIL);
2155	    GC_PROTECT(list);
2156	}
2157	else {
2158	    RPLACD(cons, CONS(pair, NIL));
2159	    cons = CDR(cons);
2160	}
2161    }
2162    /* Add variables */
2163    for (; CONSP(list); list = CDR(list)) {
2164	pair = CAR(list);
2165	CHECK_CONSTANT(CAR(pair));
2166	LispAddVar(CAR(pair), CDR(pair));
2167	++lisp__data.env.head;
2168    }
2169    /* Values of symbols are now protected */
2170    GC_LEAVE();
2171
2172    /* execute body */
2173    for (result = NIL; CONSP(body); body = CDR(body))
2174	result = EVAL(CAR(body));
2175
2176    lisp__data.env.head = lisp__data.env.length = head;
2177
2178    return (result);
2179}
2180
2181LispObj *
2182Lisp_LetP(LispBuiltin *builtin)
2183/*
2184 let* init &rest body
2185 */
2186{
2187    int head = lisp__data.env.length;
2188    LispObj *init, *body, *pair, *result;
2189
2190    body = ARGUMENT(1);
2191    init = ARGUMENT(0);
2192
2193    CHECK_LIST(init);
2194    for (; CONSP(init); init = CDR(init)) {
2195	LispObj *symbol, *value;
2196
2197	pair = CAR(init);
2198	if (SYMBOLP(pair)) {
2199	    symbol = pair;
2200	    value = NIL;
2201	}
2202	else {
2203	    CHECK_CONS(pair);
2204	    symbol = CAR(pair);
2205	    CHECK_SYMBOL(symbol);
2206	    pair = CDR(pair);
2207	    if (CONSP(pair)) {
2208		value = CAR(pair);
2209		if (CDR(pair) != NIL)
2210		    LispDestroy("%s: too much arguments to initialize %s",
2211				STRFUN(builtin), STROBJ(symbol));
2212		value = EVAL(value);
2213	    }
2214	    else
2215		value = NIL;
2216	}
2217
2218	CHECK_CONSTANT(symbol);
2219	LispAddVar(symbol, value);
2220	++lisp__data.env.head;
2221    }
2222
2223    /* execute body */
2224    for (result = NIL; CONSP(body); body = CDR(body))
2225	result = EVAL(CAR(body));
2226
2227    lisp__data.env.head = lisp__data.env.length = head;
2228
2229    return (result);
2230}
2231
2232LispObj *
2233Lisp_List(LispBuiltin *builtin)
2234/*
2235 list &rest args
2236 */
2237{
2238    LispObj *args;
2239
2240    args = ARGUMENT(0);
2241
2242    return (args);
2243}
2244
2245LispObj *
2246Lisp_ListP(LispBuiltin *builtin)
2247/*
2248 list* object &rest more-objects
2249 */
2250{
2251    GC_ENTER();
2252    LispObj *result, *cons;
2253
2254    LispObj *object, *more_objects;
2255
2256    more_objects = ARGUMENT(1);
2257    object = ARGUMENT(0);
2258
2259    if (!CONSP(more_objects))
2260	return (object);
2261
2262    result = cons = CONS(object, CAR(more_objects));
2263    GC_PROTECT(result);
2264    for (more_objects = CDR(more_objects); CONSP(more_objects);
2265	 more_objects = CDR(more_objects)) {
2266	object = CAR(more_objects);
2267	RPLACD(cons, CONS(CDR(cons), object));
2268	cons = CDR(cons);
2269    }
2270    GC_LEAVE();
2271
2272    return (result);
2273}
2274
2275/* "classic" list-length */
2276LispObj *
2277Lisp_ListLength(LispBuiltin *builtin)
2278/*
2279 list-length list
2280 */
2281{
2282    long length;
2283    LispObj *fast, *slow;
2284
2285    LispObj *list;
2286
2287    list = ARGUMENT(0);
2288
2289    CHECK_LIST(list);
2290    for (fast = slow = list, length = 0;
2291	 CONSP(slow);
2292	 slow = CDR(slow), length += 2) {
2293	if (fast == NIL)
2294	    break;
2295	CHECK_CONS(fast);
2296	fast = CDR(fast);
2297	if (fast == NIL) {
2298	    ++length;
2299	    break;
2300	}
2301	CHECK_CONS(fast);
2302	fast = CDR(fast);
2303	if (slow == fast)
2304	    /* circular list */
2305	    return (NIL);
2306    }
2307
2308    return (FIXNUM(length));
2309}
2310
2311LispObj *
2312Lisp_Listp(LispBuiltin *builtin)
2313/*
2314 listp object
2315 */
2316{
2317    LispObj *object;
2318
2319    object = ARGUMENT(0);
2320
2321    return (object == NIL || CONSP(object) ? T : NIL);
2322}
2323
2324static LispObj *
2325LispListSet(LispBuiltin *builtin, int function)
2326/*
2327 intersection list1 list2 &key test test-not key
2328 nintersection list1 list2 &key test test-not key
2329 set-difference list1 list2 &key test test-not key
2330 nset-difference list1 list2 &key test test-not key
2331 set-exclusive-or list1 list2 &key test test-not key
2332 nset-exclusive-or list1 list2 &key test test-not key
2333 subsetp list1 list2 &key test test-not key
2334 union list1 list2 &key test test-not key
2335 nunion list1 list2 &key test test-not key
2336 */
2337{
2338    GC_ENTER();
2339    int code, expect, value, inplace, check_list2,
2340	intersection, setdifference, xunion, setexclusiveor;
2341    LispObj *lambda, *result, *cmp, *cmp1, *cmp2,
2342	    *item, *clist1, *clist2, *cons, *cdr;
2343
2344    LispObj *list1, *list2, *test, *test_not, *key;
2345
2346    key = ARGUMENT(4);
2347    test_not = ARGUMENT(3);
2348    test = ARGUMENT(2);
2349    list2 = ARGUMENT(1);
2350    list1 = ARGUMENT(0);
2351
2352    /* Check if arguments are valid lists */
2353    CHECK_LIST(list1);
2354    CHECK_LIST(list2);
2355
2356    setdifference = intersection = xunion = setexclusiveor = inplace = 0;
2357    switch (function) {
2358	case NSETDIFFERENCE:
2359	    inplace = 1;
2360	case SETDIFFERENCE:
2361	    setdifference = 1;
2362	    break;
2363	case NINTERSECTION:
2364	    inplace = 1;
2365	case INTERSECTION:
2366	    intersection = 1;
2367	    break;
2368	case NUNION:
2369	    inplace = 1;
2370	case UNION:
2371	    xunion = 1;
2372	    break;
2373	case NSETEXCLUSIVEOR:
2374	    inplace = 1;
2375	case SETEXCLUSIVEOR:
2376	    setexclusiveor = 1;
2377	    break;
2378    }
2379
2380    /* Check for fast return */
2381    if (list1 == NIL)
2382	return (setdifference || intersection ?
2383		NIL : function == SUBSETP ? T : list2);
2384    if (list2 == NIL)
2385	return (intersection || xunion || function == SUBSETP ? NIL : list1);
2386
2387    CHECK_TEST();
2388    clist1 = cdr = NIL;
2389
2390    /* Make a copy of list2 with the key predicate applied */
2391    if (key != UNSPEC) {
2392	result = cons = CONS(APPLY1(key, CAR(list2)), NIL);
2393	GC_PROTECT(result);
2394	for (cmp2 = CDR(list2); CONSP(cmp2); cmp2 = CDR(cmp2)) {
2395	    item = APPLY1(key, CAR(cmp2));
2396	    RPLACD(cons, CONS(APPLY1(key, CAR(cmp2)), NIL));
2397	    cons = CDR(cons);
2398	}
2399	/* check if list2 is a proper list */
2400	CHECK_LIST(cmp2);
2401	clist2 = result;
2402	check_list2 = 0;
2403    }
2404    else {
2405	clist2 = list2;
2406	check_list2 = 1;
2407    }
2408    result = cons = NIL;
2409
2410    /* Compare elements of lists
2411     * Logic:
2412     *	   UNION
2413     *		1) Walk list1 and if CAR(list1) not in list2, add it to result
2414     *		2) Add list2 to result
2415     *	   INTERSECTION
2416     *		1) Walk list1 and if CAR(list1) in list2, add it to result
2417     *	   SET-DIFFERENCE
2418     *		1) Walk list1 and if CAR(list1) not in list2, add it to result
2419     *	   SET-EXCLUSIVE-OR
2420     *		1) Walk list1 and if CAR(list1) not in list2, add it to result
2421     *		2) Walk list2 and if CAR(list2) not in list1, add it to result
2422     *	   SUBSETP
2423     *		1) Walk list1 and if CAR(list1) not in list2, return NIL
2424     *		2) Return T
2425     */
2426    value = 0;
2427    for (cmp1 = list1; CONSP(cmp1); cmp1 = CDR(cmp1)) {
2428	item = CAR(cmp1);
2429
2430	/* Apply key predicate if required */
2431	if (key != UNSPEC) {
2432	    cmp = APPLY1(key, item);
2433	    if (setexclusiveor) {
2434		if (clist1 == NIL) {
2435		    clist1 = cdr = CONS(cmp, NIL);
2436		    GC_PROTECT(clist1);
2437		}
2438		else {
2439		    RPLACD(cdr, CONS(cmp, NIL));
2440		    cdr = CDR(cdr);
2441		}
2442	    }
2443	}
2444	else
2445	    cmp = item;
2446
2447	/* Compare against list2 */
2448	for (cmp2 = clist2; CONSP(cmp2); cmp2 = CDR(cmp2)) {
2449	    value = FCOMPARE(lambda, cmp, CAR(cmp2), code);
2450	    if (value == expect)
2451		break;
2452	}
2453	if (check_list2 && value != expect) {
2454	    /* check if list2 is a proper list */
2455	    CHECK_LIST(cmp2);
2456	    check_list2 = 0;
2457	}
2458
2459	if (function == SUBSETP) {
2460	    /* Element of list1 not in list2? */
2461	    if (value != expect) {
2462		GC_LEAVE();
2463
2464		return (NIL);
2465	    }
2466	}
2467	/* If need to add item to result */
2468	else if (((setdifference || xunion || setexclusiveor) &&
2469		  value != expect) ||
2470		 (intersection && value == expect)) {
2471	    if (inplace) {
2472		if (result == NIL)
2473		    result = cons = cmp1;
2474		else {
2475		    if (setexclusiveor) {
2476			/* don't remove elements yet, will need
2477			 * to check agains't list2 later */
2478			for (cmp2 = cons; CDR(cmp2) != cmp1; cmp2 = CDR(cmp2))
2479			    ;
2480			if (cmp2 != cons) {
2481			    RPLACD(cmp2, list1);
2482			    list1 = cmp2;
2483			}
2484		    }
2485		    RPLACD(cons, cmp1);
2486		    cons = cmp1;
2487		}
2488	    }
2489	    else {
2490		if (result == NIL) {
2491		    result = cons = CONS(item, NIL);
2492		    GC_PROTECT(result);
2493		}
2494		else {
2495		    RPLACD(cons, CONS(item, NIL));
2496		    cons = CDR(cons);
2497		}
2498	    }
2499	}
2500    }
2501    /* check if list1 is a proper list */
2502    CHECK_LIST(cmp1);
2503
2504    if (function == SUBSETP) {
2505	GC_LEAVE();
2506
2507	return (T);
2508    }
2509    else if (xunion) {
2510	/* Add list2 to tail of result */
2511	if (result == NIL)
2512	    result = list2;
2513	else
2514	    RPLACD(cons, list2);
2515    }
2516    else if (setexclusiveor) {
2517	LispObj *result2, *cons2;
2518
2519	result2 = cons2 = NIL;
2520	for (cmp2 = list2; CONSP(cmp2); cmp2 = CDR(cmp2)) {
2521	    item = CAR(cmp2);
2522
2523	    if (key != UNSPEC) {
2524		cmp = CAR(clist2);
2525		/* XXX changing clist2 */
2526		clist2 = CDR(clist2);
2527		cmp1 = clist1;
2528	    }
2529	    else {
2530		cmp = item;
2531		cmp1 = list1;
2532	    }
2533
2534	    /* Compare against list1 */
2535	    for (; CONSP(cmp1); cmp1 = CDR(cmp1)) {
2536		value = FCOMPARE(lambda, cmp, CAR(cmp1), code);
2537		if (value == expect)
2538		    break;
2539	    }
2540
2541	    if (value != expect) {
2542		if (inplace) {
2543		    if (result2 == NIL)
2544			result2 = cons2 = cmp2;
2545		    else {
2546			RPLACD(cons2, cmp2);
2547			cons2 = cmp2;
2548		    }
2549		}
2550		else {
2551		    if (result == NIL) {
2552			result = cons = CONS(item, NIL);
2553			GC_PROTECT(result);
2554		    }
2555		    else {
2556			RPLACD(cons, CONS(item, NIL));
2557			cons = CDR(cons);
2558		    }
2559		}
2560	    }
2561	}
2562	if (inplace) {
2563	    if (CONSP(cons2))
2564		RPLACD(cons2, NIL);
2565	    if (result == NIL)
2566		result = result2;
2567	    else
2568		RPLACD(cons, result2);
2569	}
2570    }
2571    else if ((function == NSETDIFFERENCE || function == NINTERSECTION) &&
2572	     CONSP(cons))
2573	RPLACD(cons, NIL);
2574
2575    GC_LEAVE();
2576
2577    return (result);
2578}
2579
2580LispObj *
2581Lisp_Loop(LispBuiltin *builtin)
2582/*
2583 loop &rest body
2584 */
2585{
2586    LispObj *code, *result;
2587    LispBlock *block;
2588
2589    LispObj *body;
2590
2591    body = ARGUMENT(0);
2592
2593    result = NIL;
2594    block = LispBeginBlock(NIL, LispBlockTag);
2595    if (setjmp(block->jmp) == 0) {
2596	for (;;)
2597	    for (code = body; CONSP(code); code = CDR(code))
2598		(void)EVAL(CAR(code));
2599    }
2600    LispEndBlock(block);
2601    result = lisp__data.block.block_ret;
2602
2603    return (result);
2604}
2605
2606/* XXX This function is broken, needs a review
2607 (being delayed until true array/vectors be implemented) */
2608LispObj *
2609Lisp_MakeArray(LispBuiltin *builtin)
2610/*
2611 make-array dimensions &key element-type initial-element initial-contents
2612			    adjustable fill-pointer displaced-to
2613			    displaced-index-offset
2614 */
2615{
2616    long rank = 0, count = 1, offset, zero, c;
2617    LispObj *obj, *dim, *array;
2618    LispType type;
2619
2620    LispObj *dimensions, *element_type, *initial_element, *initial_contents,
2621	    *displaced_to, *displaced_index_offset;
2622
2623    dim = array = NIL;
2624    type = LispNil_t;
2625
2626    displaced_index_offset = ARGUMENT(7);
2627    displaced_to = ARGUMENT(6);
2628    initial_contents = ARGUMENT(3);
2629    initial_element = ARGUMENT(2);
2630    element_type = ARGUMENT(1);
2631    dimensions = ARGUMENT(0);
2632
2633    if (INDEXP(dimensions)) {
2634	dim = CONS(dimensions, NIL);
2635	rank = 1;
2636	count = FIXNUM_VALUE(dimensions);
2637    }
2638    else if (CONSP(dimensions)) {
2639	dim = dimensions;
2640
2641	for (rank = 0; CONSP(dim); rank++, dim = CDR(dim)) {
2642	    obj = CAR(dim);
2643	    CHECK_INDEX(obj);
2644	    count *= FIXNUM_VALUE(obj);
2645	}
2646	dim = dimensions;
2647    }
2648    else if (dimensions == NIL) {
2649	dim = NIL;
2650	rank = count = 0;
2651    }
2652    else
2653	LispDestroy("%s: %s is a bad array dimension",
2654		    STRFUN(builtin), STROBJ(dimensions));
2655
2656    /* check element-type */
2657    if (element_type != UNSPEC) {
2658	if (element_type == T)
2659	    type = LispNil_t;
2660	else if (!SYMBOLP(element_type))
2661	    LispDestroy("%s: unsupported element type %s",
2662			STRFUN(builtin), STROBJ(element_type));
2663	else {
2664	    Atom_id atom = ATOMID(element_type);
2665
2666	    if (atom == Satom)
2667		type = LispAtom_t;
2668	    else if (atom == Sinteger)
2669		type = LispInteger_t;
2670	    else if (atom == Scharacter)
2671		type = LispSChar_t;
2672	    else if (atom == Sstring)
2673		type = LispString_t;
2674	    else if (atom == Slist)
2675		type = LispCons_t;
2676	    else if (atom == Sopaque)
2677		type = LispOpaque_t;
2678	    else
2679		LispDestroy("%s: unsupported element type %s",
2680			    STRFUN(builtin), ATOMID(element_type)->value);
2681	}
2682    }
2683
2684    /* check initial-contents */
2685    if (rank) {
2686	CHECK_LIST(initial_contents);
2687    }
2688
2689    /* check displaced-to */
2690    if (displaced_to != UNSPEC) {
2691	CHECK_ARRAY(displaced_to);
2692    }
2693
2694    /* check displaced-index-offset */
2695    offset = -1;
2696    if (displaced_index_offset != UNSPEC) {
2697	CHECK_INDEX(displaced_index_offset);
2698	offset = FIXNUM_VALUE(displaced_index_offset);
2699    }
2700
2701    c = 0;
2702    if (initial_element != UNSPEC)
2703	++c;
2704    if (initial_contents != UNSPEC)
2705	++c;
2706    if (displaced_to != UNSPEC || offset >= 0)
2707	++c;
2708    if (c > 1)
2709	LispDestroy("%s: more than one initialization specified",
2710		    STRFUN(builtin));
2711    if (initial_element == UNSPEC)
2712	initial_element = NIL;
2713
2714    zero = count == 0;
2715    if (displaced_to != UNSPEC) {
2716	CHECK_ARRAY(displaced_to);
2717	if (offset < 0)
2718	    offset = 0;
2719	for (c = 1, obj = displaced_to->data.array.dim; obj != NIL;
2720	     obj = CDR(obj))
2721	    c *= FIXNUM_VALUE(CAR(obj));
2722	if (c < count + offset)
2723	    LispDestroy("%s: array-total-size + displaced-index-offset "
2724			"exceeds total size", STRFUN(builtin));
2725	for (c = 0, array = displaced_to->data.array.list; c < offset; c++)
2726	    array = CDR(array);
2727    }
2728    else if (initial_contents != UNSPEC) {
2729	CHECK_CONS(initial_contents);
2730	if (rank == 0)
2731	    array = initial_contents;
2732	else if (rank == 1) {
2733	    for (array = initial_contents, c = 0; c < count;
2734		 array = CDR(array), c++)
2735		if (!CONSP(array))
2736		    LispDestroy("%s: bad argument or size %s",
2737				STRFUN(builtin), STROBJ(array));
2738	    if (array != NIL)
2739		LispDestroy("%s: bad argument or size %s",
2740			    STRFUN(builtin), STROBJ(array));
2741	    array = initial_contents;
2742	}
2743	else {
2744	    LispObj *err = NIL;
2745	    /* check if list matches */
2746	    int i, j, k, *dims, *loop;
2747
2748	    /* create iteration variables */
2749	    dims = LispMalloc(sizeof(int) * rank);
2750	    loop = LispCalloc(1, sizeof(int) * (rank - 1));
2751	    for (i = 0, obj = dim; CONSP(obj); i++, obj = CDR(obj))
2752		dims[i] = FIXNUM_VALUE(CAR(obj));
2753
2754	    /* check if list matches specified dimensions */
2755	    while (loop[0] < dims[0]) {
2756		for (obj = initial_contents, i = 0; i < rank - 1; i++) {
2757		    for (j = 0; j < loop[i]; j++)
2758			obj = CDR(obj);
2759		    err = obj;
2760		    if (!CONSP(obj = CAR(obj)))
2761			goto make_array_error;
2762		    err = obj;
2763		}
2764		--i;
2765		for (;;) {
2766		    ++loop[i];
2767		    if (i && loop[i] >= dims[i])
2768			loop[i] = 0;
2769		    else
2770			break;
2771		    --i;
2772		}
2773		for (k = 0; k < dims[rank - 1]; obj = CDR(obj), k++) {
2774		    if (!CONSP(obj))
2775			goto make_array_error;
2776		}
2777		if (obj == NIL)
2778		    continue;
2779make_array_error:
2780		LispFree(dims);
2781		LispFree(loop);
2782		LispDestroy("%s: bad argument or size %s",
2783			    STRFUN(builtin), STROBJ(err));
2784	    }
2785
2786	    /* list is correct, use it to fill initial values */
2787
2788	    /* reset loop */
2789	    memset(loop, 0, sizeof(int) * (rank - 1));
2790
2791	    GCDisable();
2792	    /* fill array with supplied values */
2793	    array = NIL;
2794	    while (loop[0] < dims[0]) {
2795		for (obj = initial_contents, i = 0; i < rank - 1; i++) {
2796		    for (j = 0; j < loop[i]; j++)
2797			obj = CDR(obj);
2798		    obj = CAR(obj);
2799		}
2800		--i;
2801		for (;;) {
2802		    ++loop[i];
2803		    if (i && loop[i] >= dims[i])
2804			loop[i] = 0;
2805		    else
2806			break;
2807		    --i;
2808		}
2809		for (k = 0; k < dims[rank - 1]; obj = CDR(obj), k++) {
2810		    if (array == NIL)
2811			array = CONS(CAR(obj), NIL);
2812		    else {
2813			RPLACD(array, CONS(CAR(array), CDR(array)));
2814			RPLACA(array, CAR(obj));
2815		    }
2816		}
2817	    }
2818	    LispFree(dims);
2819	    LispFree(loop);
2820	    array = LispReverse(array);
2821	    GCEnable();
2822	}
2823    }
2824    else {
2825	GCDisable();
2826	/* allocate array */
2827	if (count) {
2828	    --count;
2829	    array = CONS(initial_element, NIL);
2830	    while (count) {
2831		RPLACD(array, CONS(CAR(array), CDR(array)));
2832		RPLACA(array, initial_element);
2833		count--;
2834	    }
2835	}
2836	GCEnable();
2837    }
2838
2839    obj = LispNew(array, dim);
2840    obj->type = LispArray_t;
2841    obj->data.array.list = array;
2842    obj->data.array.dim = dim;
2843    obj->data.array.rank = rank;
2844    obj->data.array.type = type;
2845    obj->data.array.zero = zero;
2846
2847    return (obj);
2848}
2849
2850LispObj *
2851Lisp_MakeList(LispBuiltin *builtin)
2852/*
2853 make-list size &key initial-element
2854 */
2855{
2856    GC_ENTER();
2857    long count;
2858    LispObj *result, *cons;
2859
2860    LispObj *size, *initial_element;
2861
2862    initial_element = ARGUMENT(1);
2863    size = ARGUMENT(0);
2864
2865    CHECK_INDEX(size);
2866    count = FIXNUM_VALUE(size);
2867
2868    if (count == 0)
2869	return (NIL);
2870    if (initial_element == UNSPEC)
2871	initial_element = NIL;
2872
2873    result = cons = CONS(initial_element, NIL);
2874    GC_PROTECT(result);
2875    for (; count > 1; count--) {
2876	RPLACD(cons, CONS(initial_element, NIL));
2877	cons = CDR(cons);
2878    }
2879    GC_LEAVE();
2880
2881    return (result);
2882}
2883
2884LispObj *
2885Lisp_MakeSymbol(LispBuiltin *builtin)
2886/*
2887 make-symbol name
2888 */
2889{
2890    LispObj *name, *symbol;
2891
2892    name = ARGUMENT(0);
2893    CHECK_STRING(name);
2894
2895    symbol = UNINTERNED_ATOM(THESTR(name));
2896    symbol->data.atom->unreadable = !LispCheckAtomString(THESTR(name));
2897
2898    return (symbol);
2899}
2900
2901LispObj *
2902Lisp_Makunbound(LispBuiltin *builtin)
2903/*
2904 makunbound symbol
2905 */
2906{
2907    LispObj *symbol;
2908
2909    symbol = ARGUMENT(0);
2910
2911    CHECK_SYMBOL(symbol);
2912    LispUnsetVar(symbol);
2913
2914    return (symbol);
2915}
2916
2917LispObj *
2918Lisp_Mapc(LispBuiltin *builtin)
2919/*
2920 mapc function list &rest more-lists
2921 */
2922{
2923    return (LispMapc(builtin, 0));
2924}
2925
2926LispObj *
2927Lisp_Mapcar(LispBuiltin *builtin)
2928/*
2929 mapcar function list &rest more-lists
2930 */
2931{
2932    return (LispMapc(builtin, 1));
2933}
2934
2935/* Like nconc but ignore non list arguments */
2936LispObj *
2937LispMapnconc(LispObj *list)
2938{
2939    LispObj *result = NIL;
2940
2941    if (CONSP(list)) {
2942	LispObj *cons, *head, *tail;
2943
2944	cons = NIL;
2945	for (; CONSP(CDR(list)); list = CDR(list)) {
2946	    head = CAR(list);
2947	    if (CONSP(head)) {
2948		for (tail = head; CONSP(CDR(tail)); tail = CDR(tail))
2949		    ;
2950		if (cons != NIL)
2951		    RPLACD(cons, head);
2952		else
2953		    result = head;
2954		cons = tail;
2955	    }
2956	}
2957	head = CAR(list);
2958	if (CONSP(head)) {
2959	    if (cons != NIL)
2960		RPLACD(cons, head);
2961	    else
2962		result = head;
2963	}
2964    }
2965
2966    return (result);
2967}
2968
2969LispObj *
2970Lisp_Mapcan(LispBuiltin *builtin)
2971/*
2972 mapcan function list &rest more-lists
2973 */
2974{
2975    return (LispMapnconc(LispMapc(builtin, 1)));
2976}
2977
2978static LispObj *
2979LispMapc(LispBuiltin *builtin, int mapcar)
2980{
2981    GC_ENTER();
2982    long i, offset, count, length;
2983    LispObj *result = NIL, *cons, *arguments, *acons, *rest, *alist, *value;
2984    LispObj *stk[8], **cdrs;
2985
2986    LispObj *function, *list, *more_lists;
2987
2988    more_lists = ARGUMENT(2);
2989    list = ARGUMENT(1);
2990    function = ARGUMENT(0);
2991
2992    /* Result will be no longer than this */
2993    for (length = 0, alist = list; CONSP(alist); length++, alist = CDR(alist))
2994	;
2995
2996    /* If first argument is not a list... */
2997    if (length == 0)
2998	return (NIL);
2999
3000    /* At least one argument will be passed to function, count how many
3001     * extra arguments will be used, and calculate result length. */
3002    count = 0;
3003    for (rest = more_lists; CONSP(rest); rest = CDR(rest), count++) {
3004
3005	/* Check if extra list is really a list, and if it is smaller
3006	 * than the first list */
3007	for (i = 0, alist = CAR(rest);
3008	     i < length && CONSP(alist);
3009	     i++, alist = CDR(alist))
3010	    ;
3011
3012	/* If it is not a true list */
3013	if (i == 0)
3014	    return (NIL);
3015
3016	/* If it is smaller than the currently calculated result length */
3017	if (i < length)
3018	    length = i;
3019    }
3020
3021    if (mapcar) {
3022	/* Initialize gc protected object cells for resulting list */
3023	result = cons = CONS(NIL, NIL);
3024	GC_PROTECT(result);
3025    }
3026    else
3027	result = cons = list;
3028
3029    if (count >= sizeof(stk) / sizeof(stk[0]))
3030	cdrs = LispMalloc(count * sizeof(LispObj*));
3031    else
3032	cdrs = &stk[0];
3033    for (i = 0, rest = more_lists; i < count; i++, rest = CDR(rest))
3034	cdrs[i] = CAR(rest);
3035
3036    /* Initialize gc protected object cells for argument list */
3037    arguments = acons = CONS(NIL, NIL);
3038    GC_PROTECT(arguments);
3039
3040    /* Allocate space for extra arguments */
3041    for (i = 0; i < count; i++) {
3042	RPLACD(acons, CONS(NIL, NIL));
3043	acons = CDR(acons);
3044    }
3045
3046    /* For every element of the list that will be used */
3047    for (offset = 0;; list = CDR(list)) {
3048	acons = arguments;
3049
3050	/* Add first argument */
3051	RPLACA(acons, CAR(list));
3052	acons = CDR(acons);
3053
3054	/* For every extra list argument */
3055	for (i = 0; i < count; i++) {
3056	    alist = cdrs[i];
3057	    cdrs[i] = CDR(cdrs[i]);
3058
3059	    /* Add element to argument list */
3060	    RPLACA(acons, CAR(alist));
3061	    acons = CDR(acons);
3062	}
3063
3064	value = APPLY(function, arguments);
3065
3066	if (mapcar) {
3067	    /* Store result */
3068	    RPLACA(cons, value);
3069
3070	    /* Allocate new result cell */
3071	    if (++offset < length) {
3072		RPLACD(cons, CONS(NIL, NIL));
3073		cons = CDR(cons);
3074	    }
3075	    else
3076		break;
3077	}
3078	else if (++offset >= length)
3079	    break;
3080    }
3081
3082    /* Unprotect argument and result list */
3083    GC_LEAVE();
3084    if (cdrs != &stk[0])
3085	LispFree(cdrs);
3086
3087    return (result);
3088}
3089
3090static LispObj *
3091LispMapl(LispBuiltin *builtin, int maplist)
3092{
3093    GC_ENTER();
3094    long i, offset, count, length;
3095    LispObj *result = NIL, *cons, *arguments, *acons, *rest, *alist, *value;
3096    LispObj *stk[8], **cdrs;
3097
3098    LispObj *function, *list, *more_lists;
3099
3100    more_lists = ARGUMENT(2);
3101    list = ARGUMENT(1);
3102    function = ARGUMENT(0);
3103
3104    /* count is the number of lists, length is the length of the result */
3105    for (length = 0, alist = list; CONSP(alist); length++, alist = CDR(alist))
3106	;
3107
3108    /* first argument is not a list */
3109    if (length == 0)
3110	return (NIL);
3111
3112    /* check remaining arguments */
3113    for (count = 0, rest = more_lists; CONSP(rest); rest = CDR(rest), count++) {
3114	for (i = 0, alist = CAR(rest);
3115	     i < length && CONSP(alist);
3116	     i++, alist = CDR(alist))
3117	    ;
3118	/* argument is not a list */
3119	if (i == 0)
3120	    return (NIL);
3121	/* result will have the length of the smallest list */
3122	if (i < length)
3123	    length = i;
3124    }
3125
3126    /* result will be a list */
3127    if (maplist) {
3128	result = cons = CONS(NIL, NIL);
3129	GC_PROTECT(result);
3130    }
3131    else
3132	result = cons = list;
3133
3134    if (count >= sizeof(stk) / sizeof(stk[0]))
3135	cdrs = LispMalloc(count * sizeof(LispObj*));
3136    else
3137	cdrs = &stk[0];
3138    for (i = 0, rest = more_lists; i < count; i++, rest = CDR(rest))
3139	cdrs[i] = CAR(rest);
3140
3141    /* initialize argument list */
3142    arguments = acons = CONS(NIL, NIL);
3143    GC_PROTECT(arguments);
3144    for (i = 0; i < count; i++) {
3145	RPLACD(acons, CONS(NIL, NIL));
3146	acons = CDR(acons);
3147    }
3148
3149    /* for every used list element */
3150    for (offset = 0;; list = CDR(list)) {
3151	acons = arguments;
3152
3153	/* first argument */
3154	RPLACA(acons, list);
3155	acons = CDR(acons);
3156
3157	/* for every extra list */
3158	for (i = 0; i < count; i++) {
3159	    RPLACA(acons, cdrs[i]);
3160	    cdrs[i] = CDR(cdrs[i]);
3161	    acons = CDR(acons);
3162	}
3163
3164	value = APPLY(function, arguments);
3165
3166	if (maplist) {
3167	    /* store result */
3168	    RPLACA(cons, value);
3169
3170	    /* allocate new cell */
3171	    if (++offset < length) {
3172		RPLACD(cons, CONS(NIL, NIL));
3173		cons = CDR(cons);
3174	    }
3175	    else
3176		break;
3177	}
3178	else if (++offset >= length)
3179	    break;
3180    }
3181
3182    GC_LEAVE();
3183    if (cdrs != &stk[0])
3184	LispFree(cdrs);
3185
3186    return (result);
3187}
3188
3189LispObj *
3190Lisp_Mapl(LispBuiltin *builtin)
3191/*
3192 mapl function list &rest more-lists
3193 */
3194{
3195    return (LispMapl(builtin, 0));
3196}
3197
3198LispObj *
3199Lisp_Maplist(LispBuiltin *builtin)
3200/*
3201 maplist function list &rest more-lists
3202 */
3203{
3204    return (LispMapl(builtin, 1));
3205}
3206
3207LispObj *
3208Lisp_Mapcon(LispBuiltin *builtin)
3209/*
3210 mapcon function list &rest more-lists
3211 */
3212{
3213    return (LispMapnconc(LispMapl(builtin, 1)));
3214}
3215
3216LispObj *
3217Lisp_Member(LispBuiltin *builtin)
3218/*
3219 member item list &key test test-not key
3220 */
3221{
3222    int code, expect;
3223    LispObj *compare, *lambda;
3224    LispObj *item, *list, *test, *test_not, *key;
3225
3226    key = ARGUMENT(4);
3227    test_not = ARGUMENT(3);
3228    test = ARGUMENT(2);
3229    list = ARGUMENT(1);
3230    item = ARGUMENT(0);
3231
3232    if (list == NIL)
3233	return (NIL);
3234    CHECK_CONS(list);
3235
3236    CHECK_TEST();
3237    if (key == UNSPEC) {
3238	if (code == FEQ) {
3239	    for (; CONSP(list); list = CDR(list))
3240		if (item == CAR(list))
3241		    return (list);
3242	}
3243	else {
3244	    for (; CONSP(list); list = CDR(list))
3245		if ((FCOMPARE(lambda, item, CAR(list), code)) == expect)
3246		    return (list);
3247	}
3248    }
3249    else {
3250	if (code == FEQ) {
3251	    for (; CONSP(list); list = CDR(list))
3252		if (item == APPLY1(key, CAR(list)))
3253		    return (list);
3254	}
3255	else {
3256	    for (; CONSP(list); list = CDR(list)) {
3257		compare = APPLY1(key, CAR(list));
3258		if ((FCOMPARE(lambda, item, compare, code)) == expect)
3259		    return (list);
3260	    }
3261	}
3262    }
3263    /* check if is a proper list */
3264    CHECK_LIST(list);
3265
3266    return (NIL);
3267}
3268
3269LispObj *
3270Lisp_MemberIf(LispBuiltin *builtin)
3271/*
3272 member-if predicate list &key key
3273 */
3274{
3275    return (LispAssocOrMember(builtin, MEMBER, IF));
3276}
3277
3278LispObj *
3279Lisp_MemberIfNot(LispBuiltin *builtin)
3280/*
3281 member-if-not predicate list &key key
3282 */
3283{
3284    return (LispAssocOrMember(builtin, MEMBER, IFNOT));
3285}
3286
3287LispObj *
3288Lisp_MultipleValueBind(LispBuiltin *builtin)
3289/*
3290 multiple-value-bind symbols values &rest body
3291 */
3292{
3293    int i, head = lisp__data.env.length;
3294    LispObj *result, *symbol, *value;
3295
3296    LispObj *symbols, *values, *body;
3297
3298    body = ARGUMENT(2);
3299    values = ARGUMENT(1);
3300    symbols = ARGUMENT(0);
3301
3302    result = EVAL(values);
3303    for (i = -1; CONSP(symbols); symbols = CDR(symbols), i++) {
3304	symbol = CAR(symbols);
3305	CHECK_SYMBOL(symbol);
3306	CHECK_CONSTANT(symbol);
3307	if (i >= 0 && i < RETURN_COUNT)
3308	    value = RETURN(i);
3309	else if (i < 0)
3310	    value = result;
3311	else
3312	    value = NIL;
3313	LispAddVar(symbol, value);
3314	++lisp__data.env.head;
3315    }
3316
3317    /* Execute code with binded variables (if any) */
3318    for (result = NIL; CONSP(body); body = CDR(body))
3319	result = EVAL(CAR(body));
3320
3321    lisp__data.env.head = lisp__data.env.length = head;
3322
3323    return (result);
3324}
3325
3326LispObj *
3327Lisp_MultipleValueCall(LispBuiltin *builtin)
3328/*
3329 multiple-value-call function &rest form
3330 */
3331{
3332    GC_ENTER();
3333    int i;
3334    LispObj *arguments, *cons, *result;
3335
3336    LispObj *function, *form;
3337
3338    form = ARGUMENT(1);
3339    function = ARGUMENT(0);
3340
3341    /* build argument list */
3342    arguments = cons = NIL;
3343    for (; CONSP(form); form = CDR(form)) {
3344	RETURN_COUNT = 0;
3345	result = EVAL(CAR(form));
3346	if (RETURN_COUNT >= 0) {
3347	    if (arguments == NIL) {
3348		arguments = cons = CONS(result, NIL);
3349		GC_PROTECT(arguments);
3350	    }
3351	    else {
3352		RPLACD(cons, CONS(result, NIL));
3353		cons = CDR(cons);
3354	    }
3355	    for (i = 0; i < RETURN_COUNT; i++) {
3356		RPLACD(cons, CONS(RETURN(i), NIL));
3357		cons = CDR(cons);
3358	    }
3359	}
3360    }
3361
3362    /* apply function */
3363    if (POINTERP(function) && !XSYMBOLP(function) && !XFUNCTIONP(function)) {
3364	function = EVAL(function);
3365	GC_PROTECT(function);
3366    }
3367    result = APPLY(function, arguments);
3368    GC_LEAVE();
3369
3370    return (result);
3371}
3372
3373LispObj *
3374Lisp_MultipleValueProg1(LispBuiltin *builtin)
3375/*
3376 multiple-value-prog1 first-form &rest form
3377 */
3378{
3379    GC_ENTER();
3380    int i, count;
3381    LispObj *values, *cons;
3382
3383    LispObj *first_form, *form;
3384
3385    form = ARGUMENT(1);
3386    first_form = ARGUMENT(0);
3387
3388    values = EVAL(first_form);
3389    if (!CONSP(form))
3390	return (values);
3391
3392    cons = NIL;
3393    count = RETURN_COUNT;
3394    if (count < 0)
3395	values = NIL;
3396    else if (count == 0) {
3397	GC_PROTECT(values);
3398    }
3399    else {
3400	values = cons = CONS(values, NIL);
3401	GC_PROTECT(values);
3402	for (i = 0; i < count; i++) {
3403	    RPLACD(cons, CONS(RETURN(i), NIL));
3404	    cons = CDR(cons);
3405	}
3406    }
3407
3408    for (; CONSP(form); form = CDR(form))
3409	EVAL(CAR(form));
3410
3411    RETURN_COUNT = count;
3412    if (count > 0) {
3413	for (i = 0, cons = CDR(values); CONSP(cons); cons = CDR(cons), i++)
3414	    RETURN(i) = CAR(cons);
3415	values = CAR(values);
3416    }
3417    GC_LEAVE();
3418
3419    return (values);
3420}
3421
3422LispObj *
3423Lisp_MultipleValueList(LispBuiltin *builtin)
3424/*
3425 multiple-value-list form
3426 */
3427{
3428    int i;
3429    GC_ENTER();
3430    LispObj *form, *result, *cons;
3431
3432    form = ARGUMENT(0);
3433
3434    result = EVAL(form);
3435
3436    if (RETURN_COUNT < 0)
3437	return (NIL);
3438
3439    result = cons = CONS(result, NIL);
3440    GC_PROTECT(result);
3441    for (i = 0; i < RETURN_COUNT; i++) {
3442	RPLACD(cons, CONS(RETURN(i), NIL));
3443	cons = CDR(cons);
3444    }
3445    GC_LEAVE();
3446
3447    return (result);
3448}
3449
3450LispObj *
3451Lisp_MultipleValueSetq(LispBuiltin *builtin)
3452/*
3453 multiple-value-setq symbols form
3454 */
3455{
3456    int i;
3457    LispObj *result, *symbol, *value;
3458
3459    LispObj *symbols, *form;
3460
3461    form = ARGUMENT(1);
3462    symbols = ARGUMENT(0);
3463
3464    CHECK_LIST(symbols);
3465    result = EVAL(form);
3466    if (CONSP(symbols)) {
3467	symbol = CAR(symbols);
3468	CHECK_SYMBOL(symbol);
3469	CHECK_CONSTANT(symbol);
3470	LispSetVar(symbol, result);
3471	symbols = CDR(symbols);
3472    }
3473    for (i = 0; CONSP(symbols); symbols = CDR(symbols), i++) {
3474	symbol = CAR(symbols);
3475	CHECK_SYMBOL(symbol);
3476	CHECK_CONSTANT(symbol);
3477	if (i < RETURN_COUNT && RETURN_COUNT > 0)
3478	    value = RETURN(i);
3479	else
3480	    value = NIL;
3481	LispSetVar(symbol, value);
3482    }
3483
3484    return (result);
3485}
3486
3487LispObj *
3488Lisp_Nconc(LispBuiltin *builtin)
3489/*
3490 nconc &rest lists
3491 */
3492{
3493    LispObj *list, *lists, *cons, *head, *tail;
3494
3495    lists = ARGUMENT(0);
3496
3497    /* skip any initial empty lists */
3498    for (; CONSP(lists); lists = CDR(lists))
3499	if (CAR(lists) != NIL)
3500	    break;
3501
3502    /* don't check if a proper list */
3503    if (!CONSP(lists))
3504	return (lists);
3505
3506    /* setup to concatenate lists */
3507    list = CAR(lists);
3508    CHECK_CONS(list);
3509    for (cons = list; CONSP(CDR(cons)); cons = CDR(cons))
3510	;
3511
3512    /* if only two lists */
3513    lists = CDR(lists);
3514    if (!CONSP(lists)) {
3515	RPLACD(cons, lists);
3516
3517	return (list);
3518    }
3519
3520    /* concatenate */
3521    for (; CONSP(CDR(lists)); lists = CDR(lists)) {
3522	head = CAR(lists);
3523	if (head == NIL)
3524	    continue;
3525	CHECK_CONS(head);
3526	for (tail = head; CONSP(CDR(tail)); tail = CDR(tail))
3527	    ;
3528	RPLACD(cons, head);
3529	cons = tail;
3530    }
3531    /* add last list */
3532    RPLACD(cons, CAR(lists));
3533
3534    return (list);
3535}
3536
3537LispObj *
3538Lisp_Nreverse(LispBuiltin *builtin)
3539/*
3540 nreverse sequence
3541 */
3542{
3543    return (LispXReverse(builtin, 1));
3544}
3545
3546LispObj *
3547Lisp_NsetDifference(LispBuiltin *builtin)
3548/*
3549 nset-difference list1 list2 &key test test-not key
3550 */
3551{
3552    return (LispListSet(builtin, NSETDIFFERENCE));
3553}
3554
3555LispObj *
3556Lisp_Nsubstitute(LispBuiltin *builtin)
3557/*
3558 nsubstitute newitem olditem sequence &key from-end test test-not start end count key
3559 */
3560{
3561    return (LispDeleteRemoveXSubstitute(builtin, NSUBSTITUTE, NONE));
3562}
3563
3564LispObj *
3565Lisp_NsubstituteIf(LispBuiltin *builtin)
3566/*
3567 nsubstitute-if newitem test sequence &key from-end start end count key
3568 */
3569{
3570    return (LispDeleteRemoveXSubstitute(builtin, NSUBSTITUTE, IF));
3571}
3572
3573LispObj *
3574Lisp_NsubstituteIfNot(LispBuiltin *builtin)
3575/*
3576 nsubstitute-if-not newitem test sequence &key from-end start end count key
3577 */
3578{
3579    return (LispDeleteRemoveXSubstitute(builtin, NSUBSTITUTE, IFNOT));
3580}
3581
3582LispObj *
3583Lisp_Nth(LispBuiltin *builtin)
3584/*
3585 nth index list
3586 */
3587{
3588    long position;
3589    LispObj *oindex, *list;
3590
3591    list = ARGUMENT(1);
3592    oindex = ARGUMENT(0);
3593
3594    CHECK_INDEX(oindex);
3595    position = FIXNUM_VALUE(oindex);
3596
3597    if (list == NIL)
3598	return (NIL);
3599
3600    CHECK_CONS(list);
3601    for (; position > 0; position--) {
3602	if (!CONSP(list))
3603	    return (NIL);
3604	list = CDR(list);
3605    }
3606
3607    return (CONSP(list) ? CAR(list) : NIL);
3608}
3609
3610LispObj *
3611Lisp_Nthcdr(LispBuiltin *builtin)
3612/*
3613 nthcdr index list
3614 */
3615{
3616    long position;
3617    LispObj *oindex, *list;
3618
3619    list = ARGUMENT(1);
3620    oindex = ARGUMENT(0);
3621
3622    CHECK_INDEX(oindex);
3623    position = FIXNUM_VALUE(oindex);
3624
3625    if (list == NIL)
3626	return (NIL);
3627    CHECK_CONS(list);
3628
3629    for (; position > 0; position--) {
3630	if (!CONSP(list))
3631	    return (NIL);
3632	list = CDR(list);
3633    }
3634
3635    return (list);
3636}
3637
3638LispObj *
3639Lisp_NthValue(LispBuiltin *builtin)
3640/*
3641 nth-value index form
3642 */
3643{
3644    long i;
3645    LispObj *oindex, *form, *result;
3646
3647    form = ARGUMENT(1);
3648    oindex = ARGUMENT(0);
3649
3650    oindex = EVAL(oindex);
3651    CHECK_INDEX(oindex);
3652    i = FIXNUM_VALUE(oindex) - 1;
3653
3654    result = EVAL(form);
3655    if (RETURN_COUNT < 0 || i >= RETURN_COUNT)
3656	result = NIL;
3657    else if (i >= 0)
3658	result = RETURN(i);
3659
3660    return (result);
3661}
3662
3663LispObj *
3664Lisp_Null(LispBuiltin *builtin)
3665/*
3666 null list
3667 */
3668{
3669    LispObj *list;
3670
3671    list = ARGUMENT(0);
3672
3673    return (list == NIL ? T : NIL);
3674}
3675
3676LispObj *
3677Lisp_Or(LispBuiltin *builtin)
3678/*
3679 or &rest args
3680 */
3681{
3682    LispObj *result = NIL, *args;
3683
3684    args = ARGUMENT(0);
3685
3686    for (; CONSP(args); args = CDR(args)) {
3687	result = EVAL(CAR(args));
3688	if (result != NIL)
3689	    break;
3690    }
3691
3692    return (result);
3693}
3694
3695LispObj *
3696Lisp_Pairlis(LispBuiltin *builtin)
3697/*
3698 pairlis key data &optional alist
3699 */
3700{
3701    LispObj *result, *cons;
3702
3703    LispObj *key, *data, *alist;
3704
3705    alist = ARGUMENT(2);
3706    data = ARGUMENT(1);
3707    key = ARGUMENT(0);
3708
3709    if (CONSP(key) && CONSP(data)) {
3710	GC_ENTER();
3711
3712	result = cons = CONS(CONS(CAR(key), CAR(data)), NIL);
3713	GC_PROTECT(result);
3714	key = CDR(key);
3715	data = CDR(data);
3716	for (; CONSP(key) && CONSP(data); key = CDR(key), data = CDR(data)) {
3717	    RPLACD(cons, CONS(CONS(CAR(key), CAR(data)), NIL));
3718	    cons = CDR(cons);
3719	}
3720	if (CONSP(key) || CONSP(data))
3721	    LispDestroy("%s: different length lists", STRFUN(builtin));
3722	GC_LEAVE();
3723	if (alist != UNSPEC)
3724	    RPLACD(cons, alist);
3725    }
3726    else
3727	result = alist == UNSPEC ? NIL : alist;
3728
3729    return (result);
3730}
3731
3732static LispObj *
3733LispFindOrPosition(LispBuiltin *builtin,
3734		   int function, int comparison)
3735/*
3736 find item sequence &key from-end test test-not start end key
3737 find-if predicate sequence &key from-end start end key
3738 find-if-not predicate sequence &key from-end start end key
3739 position item sequence &key from-end test test-not start end key
3740 position-if predicate sequence &key from-end start end key
3741 position-if-not predicate sequence &key from-end start end key
3742 */
3743{
3744    int code = 0, istring, expect, value;
3745    char *string = NULL;
3746    long offset = -1, start, end, length, i = comparison == NONE ? 7 : 5;
3747    LispObj *cmp, *element, **objects = NULL;
3748
3749    LispObj *item, *predicate, *sequence, *from_end,
3750	    *test, *test_not, *ostart, *oend, *key;
3751
3752    key = ARGUMENT(i);		--i;
3753    oend = ARGUMENT(i);		--i;
3754    ostart = ARGUMENT(i);	--i;
3755    if (comparison == NONE) {
3756	test_not = ARGUMENT(i);	--i;
3757	test = ARGUMENT(i);	--i;
3758    }
3759    else
3760	test_not = test = UNSPEC;
3761    from_end = ARGUMENT(i);	--i;
3762    if (from_end == UNSPEC)
3763	from_end = NIL;
3764    sequence = ARGUMENT(i);	--i;
3765    if (comparison == NONE) {
3766	item = ARGUMENT(i);
3767	predicate = Oeql;
3768    }
3769    else {
3770	predicate = ARGUMENT(i);
3771	item = NIL;
3772    }
3773
3774    LispCheckSequenceStartEnd(builtin, sequence, ostart, oend,
3775			      &start, &end, &length);
3776
3777    if (sequence == NIL)
3778	return (NIL);
3779
3780    /* Cannot specify both :test and :test-not */
3781    if (test != UNSPEC && test_not != UNSPEC)
3782	LispDestroy("%s: specify either :TEST or :TEST-NOT", STRFUN(builtin));
3783
3784    expect = 1;
3785    if (comparison == NONE) {
3786	if (test != UNSPEC)
3787	    predicate = test;
3788	else if (test_not != UNSPEC) {
3789	    predicate = test_not;
3790	    expect = 0;
3791	}
3792	FUNCTION_CHECK(predicate);
3793	code = FCODE(predicate);
3794    }
3795
3796    cmp = element = NIL;
3797    istring = STRINGP(sequence);
3798    if (istring)
3799	string = THESTR(sequence);
3800    else {
3801	if (!CONSP(sequence))
3802	    sequence = sequence->data.array.list;
3803	for (i = 0; i < start; i++)
3804	    sequence = CDR(sequence);
3805    }
3806
3807    if ((length = end - start) == 0)
3808	return (NIL);
3809
3810    if (from_end != NIL && !istring) {
3811	objects = LispMalloc(sizeof(LispObj*) * length);
3812	for (i = length - 1; i >= 0; i--, sequence = CDR(sequence))
3813	    objects[i] = CAR(sequence);
3814    }
3815
3816    for (i = 0; i < length; i++) {
3817	if (istring)
3818	    element = SCHAR(string[from_end == NIL ? i + start : end - i - 1]);
3819	else
3820	    element = from_end == NIL ? CAR(sequence) : objects[i];
3821
3822	if (key != UNSPEC)
3823	    cmp = APPLY1(key, element);
3824	else
3825	    cmp = element;
3826
3827	/* Update list */
3828	if (!istring && from_end == NIL)
3829	    sequence = CDR(sequence);
3830
3831	if (comparison == NONE)
3832	    value = FCOMPARE(predicate, item, cmp, code);
3833	else
3834	    value = APPLY1(predicate, cmp) != NIL;
3835
3836	if ((!value &&
3837	     (comparison == IFNOT ||
3838	      (comparison == NONE && !expect))) ||
3839	    (value &&
3840	     (comparison == IF ||
3841	      (comparison == NONE && expect)))) {
3842	    offset = from_end == NIL ? i + start : end - i - 1;
3843	    break;
3844	}
3845    }
3846
3847    if (from_end != NIL && !istring)
3848	LispFree(objects);
3849
3850    return (offset == -1 ? NIL : function == FIND ? element : FIXNUM(offset));
3851}
3852
3853LispObj *
3854Lisp_Pop(LispBuiltin *builtin)
3855/*
3856 pop place
3857 */
3858{
3859    LispObj *result, *value;
3860
3861    LispObj *place;
3862
3863    place = ARGUMENT(0);
3864
3865    if (SYMBOLP(place)) {
3866	result = LispGetVar(place);
3867	if (result == NULL)
3868	    LispDestroy("EVAL: the variable %s is unbound", STROBJ(place));
3869	CHECK_CONSTANT(place);
3870	if (result != NIL) {
3871	    CHECK_CONS(result);
3872	    value = CDR(result);
3873	    result = CAR(result);
3874	}
3875	else
3876	    value = NIL;
3877	LispSetVar(place, value);
3878    }
3879    else {
3880	GC_ENTER();
3881	LispObj quote;
3882
3883	result = EVAL(place);
3884	if (result != NIL) {
3885	    CHECK_CONS(result);
3886	    value = CDR(result);
3887	    GC_PROTECT(value);
3888	    result = CAR(result);
3889	}
3890	else
3891	    value = NIL;
3892	quote.type = LispQuote_t;
3893	quote.data.quote = value;
3894	APPLY2(Osetf, place, &quote);
3895	GC_LEAVE();
3896    }
3897
3898    return (result);
3899}
3900
3901LispObj *
3902Lisp_Position(LispBuiltin *builtin)
3903/*
3904 position item sequence &key from-end test test-not start end key
3905 */
3906{
3907    return (LispFindOrPosition(builtin, POSITION, NONE));
3908}
3909
3910LispObj *
3911Lisp_PositionIf(LispBuiltin *builtin)
3912/*
3913 position-if predicate sequence &key from-end start end key
3914 */
3915{
3916    return (LispFindOrPosition(builtin, POSITION, IF));
3917}
3918
3919LispObj *
3920Lisp_PositionIfNot(LispBuiltin *builtin)
3921/*
3922 position-if-not predicate sequence &key from-end start end key
3923 */
3924{
3925    return (LispFindOrPosition(builtin, POSITION, IFNOT));
3926}
3927
3928LispObj *
3929Lisp_Proclaim(LispBuiltin *builtin)
3930/*
3931 proclaim declaration
3932 */
3933{
3934    LispObj *arguments, *object;
3935    char *operation;
3936
3937    LispObj *declaration;
3938
3939    declaration = ARGUMENT(0);
3940
3941    CHECK_CONS(declaration);
3942
3943    arguments = declaration;
3944    object = CAR(arguments);
3945    CHECK_SYMBOL(object);
3946
3947    operation = ATOMID(object)->value;
3948    if (strcmp(operation, "SPECIAL") == 0) {
3949	for (arguments = CDR(arguments); CONSP(arguments);
3950	     arguments = CDR(arguments)) {
3951	    object = CAR(arguments);
3952	    CHECK_SYMBOL(object);
3953	    LispProclaimSpecial(object, NULL, NIL);
3954	}
3955    }
3956    else if (strcmp(operation, "TYPE") == 0) {
3957	/* XXX no type checking yet, but should be added */
3958    }
3959    /* else do nothing */
3960
3961    return (NIL);
3962}
3963
3964LispObj *
3965Lisp_Prog1(LispBuiltin *builtin)
3966/*
3967 prog1 first &rest body
3968 */
3969{
3970    GC_ENTER();
3971    LispObj *result;
3972
3973    LispObj *first, *body;
3974
3975    body = ARGUMENT(1);
3976    first = ARGUMENT(0);
3977
3978    result = EVAL(first);
3979
3980    GC_PROTECT(result);
3981    for (; CONSP(body); body = CDR(body))
3982	(void)EVAL(CAR(body));
3983    GC_LEAVE();
3984
3985    return (result);
3986}
3987
3988LispObj *
3989Lisp_Prog2(LispBuiltin *builtin)
3990/*
3991 prog2 first second &rest body
3992 */
3993{
3994    GC_ENTER();
3995    LispObj *result;
3996
3997    LispObj *first, *second, *body;
3998
3999    body = ARGUMENT(2);
4000    second = ARGUMENT(1);
4001    first = ARGUMENT(0);
4002
4003    (void)EVAL(first);
4004    result = EVAL(second);
4005    GC_PROTECT(result);
4006    for (; CONSP(body); body = CDR(body))
4007	(void)EVAL(CAR(body));
4008    GC_LEAVE();
4009
4010    return (result);
4011}
4012
4013LispObj *
4014Lisp_Progn(LispBuiltin *builtin)
4015/*
4016 progn &rest body
4017 */
4018{
4019    LispObj *result = NIL;
4020
4021    LispObj *body;
4022
4023    body = ARGUMENT(0);
4024
4025    for (; CONSP(body); body = CDR(body))
4026	result = EVAL(CAR(body));
4027
4028    return (result);
4029}
4030
4031/*
4032 *  This does what I believe is the expected behaviour (or at least
4033 * acceptable for the the interpreter), if the code being executed
4034 * ever tries to change/bind a progv symbol, the symbol state will
4035 * be restored when exiting the progv block, so, code like:
4036 *	(progv '(*x*) '(1) (defvar *x* 10))
4037 * when exiting the block, will have *x* unbound, and not a dynamic
4038 * symbol; if it was already bound, will have the old value.
4039 *  Symbols already dynamic can be freely changed, even unbounded in
4040 * the progv block.
4041 */
4042LispObj *
4043Lisp_Progv(LispBuiltin *builtin)
4044/*
4045 progv symbols values &rest body
4046 */
4047{
4048    GC_ENTER();
4049    int head = lisp__data.env.length, i, count, ostk[32], *offsets;
4050    LispObj *result, *list, *symbol, *value;
4051    int jumped;
4052    char fstk[32], *flags;
4053    LispBlock *block;
4054    LispAtom *atom;
4055
4056    LispObj *symbols, *values, *body;
4057
4058    /* Possible states */
4059#define DYNAMIC_SYMBOL		1
4060#define GLOBAL_SYMBOL		2
4061#define UNBOUND_SYMBOL		3
4062
4063    body = ARGUMENT(2);
4064    values = ARGUMENT(1);
4065    symbols = ARGUMENT(0);
4066
4067    /* get symbol names */
4068    symbols = EVAL(symbols);
4069    GC_PROTECT(symbols);
4070
4071    /* get symbol values */
4072    values = EVAL(values);
4073    GC_PROTECT(values);
4074
4075    /* count/check symbols and allocate space to remember symbol state */
4076    for (count = 0, list = symbols; CONSP(list); count++, list = CDR(list)) {
4077	symbol = CAR(list);
4078	CHECK_SYMBOL(symbol);
4079	CHECK_CONSTANT(symbol);
4080    }
4081    if (count > sizeof(fstk)) {
4082	flags = LispMalloc(count);
4083	offsets = LispMalloc(count * sizeof(int));
4084    }
4085    else {
4086	flags = &fstk[0];
4087	offsets = &ostk[0];
4088    }
4089
4090    /* store flags and save old value if required */
4091    for (i = 0, list = symbols; i < count; i++, list = CDR(list)) {
4092	atom = CAR(list)->data.atom;
4093	if (atom->dyn)
4094	    flags[i] = DYNAMIC_SYMBOL;
4095	else if (atom->a_object) {
4096	    flags[i] = GLOBAL_SYMBOL;
4097	    offsets[i] = lisp__data.protect.length;
4098	    GC_PROTECT(atom->property->value);
4099	}
4100	else
4101	    flags[i] = UNBOUND_SYMBOL;
4102    }
4103
4104    /* bind the symbols */
4105    for (i = 0, list = symbols; i < count; i++, list = CDR(list)) {
4106	symbol = CAR(list);
4107	atom = symbol->data.atom;
4108	if (CONSP(values)) {
4109	    value = CAR(values);
4110	    values = CDR(values);
4111	}
4112	else
4113	    value = NIL;
4114	if (flags[i] != DYNAMIC_SYMBOL) {
4115	    if (!atom->a_object)
4116		LispSetAtomObjectProperty(atom, value);
4117	    else
4118		SETVALUE(atom, value);
4119	}
4120	else
4121	    LispAddVar(symbol, value);
4122    }
4123    /* bind dynamic symbols */
4124    lisp__data.env.head = lisp__data.env.length;
4125
4126    jumped = 0;
4127    result = NIL;
4128    block = LispBeginBlock(NIL, LispBlockProtect);
4129    if (setjmp(block->jmp) == 0) {
4130	for (; CONSP(body); body = CDR(body))
4131	    result = EVAL(CAR(body));
4132    }
4133
4134    /* restore symbols */
4135    for (i = 0, list = symbols; i < count; i++, list = CDR(list)) {
4136	symbol = CAR(list);
4137	atom = symbol->data.atom;
4138	if (flags[i] != DYNAMIC_SYMBOL) {
4139	    if (flags[i] == UNBOUND_SYMBOL)
4140		LispUnsetVar(symbol);
4141	    else {
4142		/* restore global symbol value */
4143		LispSetAtomObjectProperty(atom, lisp__data.protect.objects
4144					  [offsets[i]]);
4145		atom->dyn = 0;
4146	    }
4147	}
4148    }
4149    /* unbind dynamic symbols */
4150    lisp__data.env.head = lisp__data.env.length = head;
4151    GC_LEAVE();
4152
4153    if (count > sizeof(fstk)) {
4154	LispFree(flags);
4155	LispFree(offsets);
4156    }
4157
4158    LispEndBlock(block);
4159    if (!lisp__data.destroyed) {
4160	if (jumped)
4161	    result = lisp__data.block.block_ret;
4162    }
4163    else {
4164	/* check if there is an unwind-protect block */
4165	LispBlockUnwind(NULL);
4166
4167	/* no unwind-protect block, return to the toplevel */
4168	LispDestroy(".");
4169    }
4170
4171    return (result);
4172}
4173
4174LispObj *
4175Lisp_Provide(LispBuiltin *builtin)
4176/*
4177 provide module
4178 */
4179{
4180    LispObj *module, *obj;
4181
4182    module = ARGUMENT(0);
4183
4184    CHECK_STRING(module);
4185    for (obj = MOD; obj != NIL; obj = CDR(obj)) {
4186	if (STRLEN(CAR(obj)) == STRLEN(module) &&
4187	    memcmp(THESTR(CAR(obj)), THESTR(module), STRLEN(module)) == 0)
4188	    return (module);
4189    }
4190
4191    if (MOD == NIL)
4192	MOD = CONS(module, NIL);
4193    else {
4194	RPLACD(MOD, CONS(CAR(MOD), CDR(MOD)));
4195	RPLACA(MOD, module);
4196    }
4197
4198    LispSetVar(lisp__data.modules, MOD);
4199
4200    return (MOD);
4201}
4202
4203LispObj *
4204Lisp_Push(LispBuiltin *builtin)
4205/*
4206 push item place
4207 */
4208{
4209    LispObj *result, *list;
4210
4211    LispObj *item, *place;
4212
4213    place = ARGUMENT(1);
4214    item = ARGUMENT(0);
4215
4216    item = EVAL(item);
4217
4218    if (SYMBOLP(place)) {
4219	list = LispGetVar(place);
4220	if (list == NULL)
4221	    LispDestroy("EVAL: the variable %s is unbound", STROBJ(place));
4222	CHECK_CONSTANT(place);
4223	LispSetVar(place, result = CONS(item, list));
4224    }
4225    else {
4226	GC_ENTER();
4227	LispObj quote;
4228
4229	list = EVAL(place);
4230	result = CONS(item, list);
4231	GC_PROTECT(result);
4232	quote.type = LispQuote_t;
4233	quote.data.quote = result;
4234	APPLY2(Osetf, place, &quote);
4235	GC_LEAVE();
4236    }
4237
4238    return (result);
4239}
4240
4241LispObj *
4242Lisp_Pushnew(LispBuiltin *builtin)
4243/*
4244 pushnew item place &key key test test-not
4245 */
4246{
4247    GC_ENTER();
4248    LispObj *result, *list;
4249
4250    LispObj *item, *place, *key, *test, *test_not;
4251
4252    test_not = ARGUMENT(4);
4253    test = ARGUMENT(3);
4254    key = ARGUMENT(2);
4255    place = ARGUMENT(1);
4256    item = ARGUMENT(0);
4257
4258    /* Evaluate place */
4259    if (SYMBOLP(place)) {
4260	list = LispGetVar(place);
4261	if (list == NULL)
4262	    LispDestroy("EVAL: the variable %s is unbound", STROBJ(place));
4263	/* Do error checking now. */
4264	CHECK_CONSTANT(place);
4265    }
4266    else
4267	/* It is possible that list is not gc protected? */
4268	list = EVAL(place);
4269
4270    item = EVAL(item);
4271    GC_PROTECT(item);
4272    if (key != UNSPEC) {
4273	key = EVAL(key);
4274	GC_PROTECT(key);
4275    }
4276    if (test != UNSPEC) {
4277	test = EVAL(test);
4278	GC_PROTECT(test);
4279    }
4280    else if (test_not != UNSPEC) {
4281	test_not = EVAL(test_not);
4282	GC_PROTECT(test_not);
4283    }
4284
4285    result = LispAdjoin(builtin, item, list, key, test, test_not);
4286
4287    /* Item already in list */
4288    if (result == list) {
4289	GC_LEAVE();
4290
4291	return (result);
4292    }
4293
4294    if (SYMBOLP(place)) {
4295	CHECK_CONSTANT(place);
4296	LispSetVar(place, result);
4297    }
4298    else {
4299	LispObj quote;
4300
4301	GC_PROTECT(result);
4302	quote.type = LispQuote_t;
4303	quote.data.quote = result;
4304	APPLY2(Osetf, place, &quote);
4305    }
4306    GC_LEAVE();
4307
4308    return (result);
4309}
4310
4311#ifdef __SUNPRO_C
4312/* prevent "Function has no return statement" error for Lisp_Quit */
4313#pragma does_not_return(exit)
4314#endif
4315
4316LispObj *
4317Lisp_Quit(LispBuiltin *builtin)
4318/*
4319 quit &optional status
4320 */
4321{
4322    int status = 0;
4323    LispObj *ostatus;
4324
4325    ostatus = ARGUMENT(0);
4326
4327    if (FIXNUMP(ostatus))
4328	status = (int)FIXNUM_VALUE(ostatus);
4329    else if (ostatus != UNSPEC)
4330	LispDestroy("%s: bad exit status argument %s",
4331		    STRFUN(builtin), STROBJ(ostatus));
4332
4333    exit(status);
4334}
4335
4336LispObj *
4337Lisp_Quote(LispBuiltin *builtin)
4338/*
4339 quote object
4340 */
4341{
4342    LispObj *object;
4343
4344    object = ARGUMENT(0);
4345
4346    return (object);
4347}
4348
4349LispObj *
4350Lisp_Replace(LispBuiltin *builtin)
4351/*
4352 replace sequence1 sequence2 &key start1 end1 start2 end2
4353 */
4354{
4355    long length, length1, length2, start1, end1, start2, end2;
4356    LispObj *sequence1, *sequence2, *ostart1, *oend1, *ostart2, *oend2;
4357
4358    oend2 = ARGUMENT(5);
4359    ostart2 = ARGUMENT(4);
4360    oend1 = ARGUMENT(3);
4361    ostart1 = ARGUMENT(2);
4362    sequence2 = ARGUMENT(1);
4363    sequence1 = ARGUMENT(0);
4364
4365    LispCheckSequenceStartEnd(builtin, sequence1, ostart1, oend1,
4366			      &start1, &end1, &length1);
4367    LispCheckSequenceStartEnd(builtin, sequence2, ostart2, oend2,
4368			      &start2, &end2, &length2);
4369
4370    if (start1 == end1 || start2 == end2)
4371	return (sequence1);
4372
4373    length = end1 - start1;
4374    if (length > end2 - start2)
4375	length = end2 - start2;
4376
4377    if (STRINGP(sequence1)) {
4378	CHECK_STRING_WRITABLE(sequence1);
4379	if (!STRINGP(sequence2))
4380	    LispDestroy("%s: cannot store %s in %s",
4381			STRFUN(builtin), STROBJ(sequence2), THESTR(sequence1));
4382
4383	memmove(THESTR(sequence1) + start1, THESTR(sequence2) + start2, length);
4384    }
4385    else {
4386	int i;
4387	LispObj *from, *to;
4388
4389	if (ARRAYP(sequence1))
4390	    sequence1 = sequence1->data.array.list;
4391	if (ARRAYP(sequence2))
4392	    sequence2 = sequence2->data.array.list;
4393
4394	/* adjust pointers */
4395	for (i = 0, from = sequence2; i < start2; i++, from = CDR(from))
4396	    ;
4397	for (i = 0, to = sequence1; i < start1; i++, to = CDR(to))
4398	    ;
4399
4400	/* copy data */
4401	for (i = 0; i < length; i++, from = CDR(from), to = CDR(to))
4402	    RPLACA(to, CAR(from));
4403    }
4404
4405    return (sequence1);
4406}
4407
4408static LispObj *
4409LispDeleteOrRemoveDuplicates(LispBuiltin *builtin, int function)
4410/*
4411 delete-duplicates sequence &key from-end test test-not start end key
4412 remove-duplicates sequence &key from-end test test-not start end key
4413 */
4414{
4415    GC_ENTER();
4416    int code, expect, value = 0;
4417    long i, j, start, end, length, count;
4418    LispObj *lambda, *result, *cons, *compare;
4419
4420    LispObj *sequence, *from_end, *test, *test_not, *ostart, *oend, *key;
4421
4422    key = ARGUMENT(6);
4423    oend = ARGUMENT(5);
4424    ostart = ARGUMENT(4);
4425    test_not = ARGUMENT(3);
4426    test = ARGUMENT(2);
4427    from_end = ARGUMENT(1);
4428    if (from_end == UNSPEC)
4429	from_end = NIL;
4430    sequence = ARGUMENT(0);
4431
4432    LispCheckSequenceStartEnd(builtin, sequence, ostart, oend,
4433			      &start, &end, &length);
4434
4435    /* Check if need to do something */
4436    if (start == end)
4437	return (sequence);
4438
4439    CHECK_TEST();
4440
4441    /* Initialize */
4442    count = 0;
4443
4444    result = cons = NIL;
4445    if (STRINGP(sequence)) {
4446	char *ptr, *string, *buffer = LispMalloc(length + 1);
4447
4448	/* Use same code, update start/end offsets */
4449	if (from_end != NIL) {
4450	    i = length - start;
4451	    start = length - end;
4452	    end = i;
4453	}
4454
4455	if (from_end == NIL)
4456	    string = THESTR(sequence);
4457	else {
4458	    /* Make a reversed copy of the sequence */
4459	    string = LispMalloc(length + 1);
4460	    for (ptr = THESTR(sequence) + length - 1, i = 0; i < length; i++)
4461		string[i] = *ptr--;
4462	    string[i] = '\0';
4463	}
4464
4465	ptr = buffer;
4466	/* Copy leading bytes */
4467	for (i = 0; i < start; i++)
4468	    *ptr++ = string[i];
4469
4470	compare = SCHAR(string[i]);
4471	if (key != UNSPEC)
4472	    compare = APPLY1(key, compare);
4473	result = cons = CONS(compare, NIL);
4474	GC_PROTECT(result);
4475	for (++i; i < end; i++) {
4476	    compare = SCHAR(string[i]);
4477	    if (key != UNSPEC)
4478		compare = APPLY1(key, compare);
4479	    RPLACD(cons, CONS(compare, NIL));
4480	    cons = CDR(cons);
4481	}
4482
4483	for (i = start; i < end; i++, result = CDR(result)) {
4484	    compare = CAR(result);
4485	    for (j = i + 1, cons = CDR(result); j < end; j++, cons = CDR(cons)) {
4486		value = FCOMPARE(lambda, compare, CAR(cons), code);
4487		if (value == expect)
4488		    break;
4489	    }
4490	    if (value != expect)
4491		*ptr++ = string[i];
4492	    else
4493		++count;
4494	}
4495
4496	if (count) {
4497	    /* Copy ending bytes */
4498	    for (; i <= length; i++)   /* Also copy the ending nul */
4499		*ptr++ = string[i];
4500
4501	    if (from_end == NIL)
4502		ptr = buffer;
4503	    else {
4504		for (i = 0, ptr = buffer + strlen(buffer);
4505		     ptr > buffer;
4506		     i++)
4507		    string[i] = *--ptr;
4508		string[i] = '\0';
4509		ptr = string;
4510		LispFree(buffer);
4511	    }
4512	    if (function == REMOVE)
4513		result = STRING2(ptr);
4514	    else {
4515		CHECK_STRING_WRITABLE(sequence);
4516		result = sequence;
4517		free(THESTR(result));
4518		THESTR(result) = ptr;
4519		LispMused(ptr);
4520	    }
4521	}
4522	else {
4523	    result = sequence;
4524	    if (from_end != NIL)
4525		LispFree(string);
4526	}
4527    }
4528    else {
4529	long xlength = end - start;
4530	LispObj *list, *object, **kobjects = NULL, **xobjects;
4531	LispObj **objects = LispMalloc(sizeof(LispObj*) * xlength);
4532
4533	if (!CONSP(sequence))
4534	    object = sequence->data.array.list;
4535	else
4536	    object = sequence;
4537	list = object;
4538
4539	for (i = 0; i < start; i++)
4540	    object = CDR(object);
4541
4542	/* Put data in a vector */
4543	if (from_end == NIL) {
4544	    for (i = 0; i < xlength; i++, object = CDR(object))
4545		objects[i] = CAR(object);
4546	}
4547	else {
4548	    for (i = xlength - 1; i >= 0; i--, object = CDR(object))
4549		objects[i] = CAR(object);
4550	}
4551
4552	/* Apply key predicate if required */
4553	if (key != UNSPEC) {
4554	    kobjects = LispMalloc(sizeof(LispObj*) * xlength);
4555	    for (i = 0; i < xlength; i++) {
4556		kobjects[i] = APPLY1(key, objects[i]);
4557		GC_PROTECT(kobjects[i]);
4558	    }
4559	    xobjects = kobjects;
4560	}
4561	else
4562	    xobjects = objects;
4563
4564	/* Check if needs to remove something */
4565	for (i = 0; i < xlength; i++) {
4566	    compare = xobjects[i];
4567	    for (j = i + 1; j < xlength; j++) {
4568		value = FCOMPARE(lambda, compare, xobjects[j], code);
4569		if (value == expect) {
4570		    objects[i] = NULL;
4571		    ++count;
4572		    break;
4573		}
4574	    }
4575	}
4576
4577	if (count) {
4578	    /* Create/set result list */
4579	    object = list;
4580
4581	    if (start) {
4582		/* Skip first elements of resulting list */
4583		if (function == REMOVE) {
4584		    result = cons = CONS(CAR(object), NIL);
4585		    GC_PROTECT(result);
4586		    for (i = 1, object = CDR(object);
4587			 i < start;
4588			 i++, object = CDR(object)) {
4589			RPLACD(cons, CONS(CAR(object), NIL));
4590			cons = CDR(cons);
4591		    }
4592		}
4593		else {
4594		    result = cons = object;
4595		    for (i = 1; i < start; i++, cons = CDR(cons))
4596			;
4597		}
4598	    }
4599	    else if (function == DELETE)
4600		result = list;
4601
4602	    /* Skip initial removed elements */
4603	    if (function == REMOVE) {
4604		for (i = 0; objects[i] == NULL && i < xlength; i++)
4605		    ;
4606	    }
4607	    else
4608		i = 0;
4609
4610	    if (i < xlength) {
4611		int xstart, xlimit, xinc;
4612
4613		if (from_end == NIL) {
4614		    xstart = i;
4615		    xlimit = xlength;
4616		    xinc = 1;
4617		}
4618		else {
4619		    xstart = xlength - 1;
4620		    xlimit = i - 1;
4621		    xinc = -1;
4622		}
4623
4624		if (function == REMOVE) {
4625		    for (i = xstart; i != xlimit; i += xinc) {
4626			if (objects[i] != NULL) {
4627			    if (result == NIL) {
4628				result = cons = CONS(objects[i], NIL);
4629				GC_PROTECT(result);
4630			    }
4631			    else {
4632				RPLACD(cons, CONS(objects[i], NIL));
4633				cons = CDR(cons);
4634			    }
4635			}
4636		    }
4637		}
4638		else {
4639		    /* Delete duplicates */
4640		    for (i = xstart; i != xlimit; i += xinc) {
4641			if (objects[i] == NULL) {
4642			    if (cons == NIL) {
4643				if (CONSP(CDR(result))) {
4644				    RPLACA(result, CADR(result));
4645				    RPLACD(result, CDDR(result));
4646				}
4647				else {
4648				    RPLACA(result, CDR(result));
4649				    RPLACD(result, NIL);
4650				}
4651			    }
4652			    else {
4653				if (CONSP(CDR(cons)))
4654				    RPLACD(cons, CDDR(cons));
4655				else
4656				    RPLACD(cons, NIL);
4657			    }
4658			}
4659			else {
4660			    if (cons == NIL)
4661				cons = result;
4662			    else
4663				cons = CDR(cons);
4664			}
4665		    }
4666		}
4667	    }
4668	    if (end < length && function == REMOVE) {
4669		for (i = start; i < end; i++, object = CDR(object))
4670		    ;
4671		if (result == NIL) {
4672		    result = cons = CONS(CAR(object), NIL);
4673		    GC_PROTECT(result);
4674		    ++i;
4675		    object = CDR(object);
4676		}
4677		for (; i < length; i++, object = CDR(object)) {
4678		    RPLACD(cons, CONS(CAR(object), NIL));
4679		    cons = CDR(cons);
4680		}
4681	    }
4682	}
4683	else
4684	    result = sequence;
4685	LispFree(objects);
4686	if (key != UNSPEC)
4687	    LispFree(kobjects);
4688
4689	if (count && !CONSP(sequence)) {
4690	    if (function == REMOVE)
4691		result = VECTOR(result);
4692	    else {
4693		length = FIXNUM_VALUE(CAR(sequence->data.array.dim)) - count;
4694		CAR(sequence->data.array.dim) = FIXNUM(length);
4695		result = sequence;
4696	    }
4697	}
4698    }
4699    GC_LEAVE();
4700
4701    return (result);
4702}
4703
4704LispObj *
4705Lisp_RemoveDuplicates(LispBuiltin *builtin)
4706/*
4707 remove-duplicates sequence &key from-end test test-not start end key
4708 */
4709{
4710    return (LispDeleteOrRemoveDuplicates(builtin, REMOVE));
4711}
4712
4713static LispObj *
4714LispDeleteRemoveXSubstitute(LispBuiltin *builtin,
4715			    int function, int comparison)
4716/*
4717 delete item sequence &key from-end test test-not start end count key
4718 delete-if predicate sequence &key from-end start end count key
4719 delete-if-not predicate sequence &key from-end start end count key
4720 remove item sequence &key from-end test test-not start end count key
4721 remove-if predicate sequence &key from-end start end count key
4722 remove-if-not predicate sequence &key from-end start end count key
4723 substitute newitem olditem sequence &key from-end test test-not start end count key
4724 substitute-if newitem test sequence &key from-end start end count key
4725 substitute-if-not newitem test sequence &key from-end start end count key
4726 nsubstitute newitem olditem sequence &key from-end test test-not start end count key
4727 nsubstitute-if newitem test sequence &key from-end start end count key
4728 nsubstitute-if-not newitem test sequence &key from-end start end count key
4729 */
4730{
4731    GC_ENTER();
4732    int code, expect, value, inplace, substitute;
4733    long i, j, start, end, length, copy, count, xstart, xend, xinc, xlength;
4734
4735    LispObj *result, *compare;
4736
4737    LispObj *item, *newitem, *lambda, *sequence, *from_end,
4738	    *test, *test_not, *ostart, *oend, *ocount, *key;
4739
4740    substitute = function == SUBSTITUTE || function == NSUBSTITUTE;
4741    if (!substitute)
4742	i = comparison == NONE ? 8 : 6;
4743    else /* substitute */
4744	i = comparison == NONE ? 9 : 7;
4745
4746    /* Get function arguments */
4747    key = ARGUMENT(i);			--i;
4748    ocount = ARGUMENT(i);		--i;
4749    oend = ARGUMENT(i);			--i;
4750    ostart = ARGUMENT(i);		--i;
4751    if (comparison == NONE) {
4752	test_not = ARGUMENT(i);		--i;
4753	test = ARGUMENT(i);		--i;
4754    }
4755    else
4756	test_not = test = UNSPEC;
4757    from_end = ARGUMENT(i);		--i;
4758    if (from_end == UNSPEC)
4759	from_end = NIL;
4760    sequence = ARGUMENT(i);		--i;
4761    if (comparison != NONE) {
4762	lambda = ARGUMENT(i);	--i;
4763	if (substitute)
4764	    newitem = ARGUMENT(0);
4765	else
4766	    newitem = NIL;
4767	item = NIL;
4768    }
4769    else {
4770	lambda = NIL;
4771	if (substitute) {
4772	    item = ARGUMENT(1);
4773	    newitem = ARGUMENT(0);
4774	}
4775	else {
4776	    item = ARGUMENT(0);
4777	    newitem = NIL;
4778	}
4779    }
4780
4781    /* Check if argument is a valid sequence, and if start/end
4782     * are correctly specified. */
4783    LispCheckSequenceStartEnd(builtin, sequence, ostart, oend,
4784			      &start, &end, &length);
4785
4786    /* Check count argument */
4787    if (ocount == UNSPEC) {
4788	count = length;
4789	/* Doesn't matter, but left to right should be slightly faster */
4790	from_end = NIL;
4791    }
4792    else {
4793	CHECK_INDEX(ocount);
4794	count = FIXNUM_VALUE(ocount);
4795    }
4796
4797    /* Check if need to do something */
4798    if (start == end || count == 0)
4799	return (sequence);
4800
4801    CHECK_TEST_0();
4802
4803    /* Resolve comparison function, and expected result of comparison */
4804    if (comparison == NONE) {
4805	if (test_not == UNSPEC) {
4806	    if (test == UNSPEC)
4807		lambda = Oeql;
4808	    else
4809		lambda = test;
4810	    expect = 1;
4811	}
4812	else {
4813	    lambda = test_not;
4814	    expect = 0;
4815	}
4816	FUNCTION_CHECK(lambda);
4817    }
4818    else
4819	expect = comparison == IFNOT ? 0 : 1;
4820
4821    /* Check for fast path to comparison function */
4822    code = FCODE(lambda);
4823
4824    /* Initialize for loop */
4825    copy = count;
4826    result = sequence;
4827    inplace = function == DELETE || function == NSUBSTITUTE;
4828    xlength = end - start;
4829
4830    /* String is easier */
4831    if (STRINGP(sequence)) {
4832	char *buffer, *string;
4833
4834	if (comparison == NONE) {
4835	    CHECK_SCHAR(item);
4836	}
4837	if (substitute) {
4838	    CHECK_SCHAR(newitem);
4839	}
4840
4841	if (from_end == NIL) {
4842	    xstart = start;
4843	    xend = end;
4844	    xinc = 1;
4845	}
4846	else {
4847	    xstart = end - 1;
4848	    xend = start - 1;
4849	    xinc = -1;
4850	}
4851
4852	string = THESTR(sequence);
4853	buffer = LispMalloc(length + 1);
4854
4855	/* Copy leading bytes, if any */
4856	for (i = 0; i < start; i++)
4857	    buffer[i] = string[i];
4858
4859	for (j = xstart; i != xend && count > 0; i += xinc) {
4860	    compare = SCHAR(string[i]);
4861	    if (key != UNSPEC) {
4862		compare = APPLY1(key, compare);
4863		/* Value returned by the key predicate may not be protected */
4864		GC_PROTECT(compare);
4865		if (comparison == NONE)
4866		    value = FCOMPARE(lambda, item, compare, code);
4867		else
4868		    value = APPLY1(lambda, compare) != NIL;
4869		/* Unprotect value returned by the key predicate */
4870		GC_LEAVE();
4871	    }
4872	    else {
4873		if (comparison == NONE)
4874		    value = FCOMPARE(lambda, item, compare, code);
4875		else
4876		    value = APPLY1(lambda, compare) != NIL;
4877	    }
4878
4879	    if (value != expect) {
4880		buffer[j] = string[i];
4881		j += xinc;
4882	    }
4883	    else {
4884		if (substitute) {
4885		    buffer[j] = SCHAR_VALUE(newitem);
4886		    j += xinc;
4887		}
4888		else
4889		    --count;
4890	    }
4891	}
4892
4893	if (count != copy && from_end != NIL)
4894	    memmove(buffer + start, buffer + copy - count, count);
4895
4896	/* Copy remaining bytes, if any */
4897	for (; i < length; i++, j++)
4898	    buffer[j] = string[i];
4899	buffer[j] = '\0';
4900
4901	xlength = length - (copy - count);
4902	if (inplace) {
4903	    CHECK_STRING_WRITABLE(sequence);
4904	    /* result is a pointer to sequence */
4905	    LispFree(THESTR(sequence));
4906	    LispMused(buffer);
4907	    THESTR(sequence) = buffer;
4908	    STRLEN(sequence) = xlength;
4909	}
4910	else
4911	    result = LSTRING2(buffer, xlength);
4912    }
4913
4914    /* If inplace, need to update CAR and CDR of sequence */
4915    else {
4916	LispObj *list, *object;
4917	LispObj **objects = LispMalloc(sizeof(LispObj*) * xlength);
4918
4919	if (!CONSP(sequence))
4920	    list = sequence->data.array.list;
4921	else
4922	    list = sequence;
4923
4924	/* Put data in a vector */
4925	for (i = 0, object = list; i < start; i++)
4926	    object = CDR(object);
4927
4928	for (i = 0; i < xlength; i++, object = CDR(object))
4929	    objects[i] = CAR(object);
4930
4931	if (from_end == NIL) {
4932	    xstart = 0;
4933	    xend = xlength;
4934	    xinc = 1;
4935	}
4936	else {
4937	    xstart = xlength - 1;
4938	    xend = -1;
4939	    xinc = -1;
4940	}
4941
4942	/* Check if needs to remove something */
4943	for (i = xstart; i != xend && count > 0; i += xinc) {
4944	    compare = objects[i];
4945	    if (key != UNSPEC) {
4946		compare = APPLY1(key, compare);
4947		GC_PROTECT(compare);
4948		if (comparison == NONE)
4949		    value = FCOMPARE(lambda, item, compare, code);
4950		else
4951		    value = APPLY1(lambda, compare) != NIL;
4952		GC_LEAVE();
4953	    }
4954	    else {
4955		if (comparison == NONE)
4956		    value = FCOMPARE(lambda, item, compare, code);
4957		else
4958		    value = APPLY1(lambda, compare) != NIL;
4959	    }
4960	    if (value == expect) {
4961		if (substitute)
4962		    objects[i] = newitem;
4963		else
4964		    objects[i] = NULL;
4965		--count;
4966	    }
4967	}
4968
4969	if (copy != count) {
4970	    LispObj *cons = NIL;
4971
4972	    i = 0;
4973	    object = list;
4974	    if (inplace) {
4975		/* While result is NIL, skip initial elements of sequence */
4976		result = start ? list : NIL;
4977
4978		/* Skip initial elements, if any */
4979		for (; i < start; i++, cons = object, object = CDR(object))
4980		    ;
4981	    }
4982	    /* Copy initial elements, if any */
4983	    else {
4984		result = NIL;
4985		if (start) {
4986		    result = cons = CONS(CAR(list), NIL);
4987		    GC_PROTECT(result);
4988		    for (++i, object = CDR(list);
4989			 i < start;
4990			 i++, object = CDR(object)) {
4991			RPLACD(cons, CONS(CAR(object), NIL));
4992		 	cons = CDR(cons);
4993		    }
4994		}
4995	    }
4996
4997	    /* Skip initial removed elements, if any */
4998	    for (i = 0; i < xlength && objects[i] == NULL; i++)
4999		;
5000
5001	    for (i = 0; i < xlength; i++, object = CDR(object)) {
5002		if (objects[i]) {
5003		    if (inplace) {
5004			if (result == NIL)
5005			    result = cons = object;
5006			else {
5007			    RPLACD(cons, object);
5008			    cons = CDR(cons);
5009			}
5010			if (function == NSUBSTITUTE)
5011			    RPLACA(cons, objects[i]);
5012		    }
5013		    else {
5014			if (result == NIL) {
5015			    result = cons = CONS(objects[i], NIL);
5016			    GC_PROTECT(result);
5017			}
5018			else {
5019			    RPLACD(cons, CONS(objects[i], NIL));
5020			    cons = CDR(cons);
5021			}
5022		    }
5023		}
5024	    }
5025
5026	    if (inplace) {
5027		if (result == NIL)
5028		    result = object;
5029		else
5030		    RPLACD(cons, object);
5031
5032		if (!CONSP(sequence)) {
5033		    result = sequence;
5034		    CAR(result)->data.array.dim =
5035			FIXNUM(length - (copy - count));
5036		}
5037	    }
5038	    else if (end < length) {
5039		i = end;
5040		/* Copy ending elements, if any */
5041		if (result == NIL) {
5042		    result = cons = CONS(CAR(object), NIL);
5043		    GC_PROTECT(result);
5044		    object = CDR(object);
5045		    i++;
5046		}
5047		for (; i < length; i++, object = CDR(object)) {
5048		    RPLACD(cons, CONS(CAR(object), NIL));
5049		    cons = CDR(cons);
5050		}
5051	    }
5052	}
5053
5054	/* Release comparison vector */
5055	LispFree(objects);
5056    }
5057
5058    GC_LEAVE();
5059
5060    return (result);
5061}
5062
5063LispObj *
5064Lisp_Remove(LispBuiltin *builtin)
5065/*
5066 remove item sequence &key from-end test test-not start end count key
5067 */
5068{
5069    return (LispDeleteRemoveXSubstitute(builtin, REMOVE, NONE));
5070}
5071
5072LispObj *
5073Lisp_RemoveIf(LispBuiltin *builtin)
5074/*
5075 remove-if predicate sequence &key from-end start end count key
5076 */
5077{
5078    return (LispDeleteRemoveXSubstitute(builtin, REMOVE, IF));
5079}
5080
5081LispObj *
5082Lisp_RemoveIfNot(LispBuiltin *builtin)
5083/*
5084 remove-if-not predicate sequence &key from-end start end count key
5085 */
5086{
5087    return (LispDeleteRemoveXSubstitute(builtin, REMOVE, IFNOT));
5088}
5089
5090LispObj *
5091Lisp_Remprop(LispBuiltin *builtin)
5092/*
5093 remprop symbol indicator
5094 */
5095{
5096    LispObj *symbol, *indicator;
5097
5098    indicator = ARGUMENT(1);
5099    symbol = ARGUMENT(0);
5100
5101    CHECK_SYMBOL(symbol);
5102
5103    return (LispRemAtomProperty(symbol->data.atom, indicator));
5104}
5105
5106LispObj *
5107Lisp_Return(LispBuiltin *builtin)
5108/*
5109 return &optional result
5110 */
5111{
5112    unsigned blevel = lisp__data.block.block_level;
5113
5114    LispObj *result;
5115
5116    result = ARGUMENT(0);
5117
5118    while (blevel) {
5119	LispBlock *block = lisp__data.block.block[--blevel];
5120
5121	if (block->type == LispBlockClosure)
5122	    /* if reached a function call */
5123	    break;
5124	if (block->type == LispBlockTag && block->tag == NIL) {
5125	    lisp__data.block.block_ret = result == UNSPEC ? NIL : EVAL(result);
5126	    LispBlockUnwind(block);
5127	    BLOCKJUMP(block);
5128	}
5129    }
5130    LispDestroy("%s: no visible NIL block", STRFUN(builtin));
5131
5132    /*NOTREACHED*/
5133    return (NIL);
5134}
5135
5136LispObj *
5137Lisp_ReturnFrom(LispBuiltin *builtin)
5138/*
5139 return-from name &optional result
5140 */
5141{
5142    unsigned blevel = lisp__data.block.block_level;
5143
5144    LispObj *name, *result;
5145
5146    result = ARGUMENT(1);
5147    name = ARGUMENT(0);
5148
5149    if (name != NIL && name != T && !SYMBOLP(name))
5150	LispDestroy("%s: %s is not a valid block name",
5151		    STRFUN(builtin), STROBJ(name));
5152
5153    while (blevel) {
5154	LispBlock *block = lisp__data.block.block[--blevel];
5155
5156	if (name == block->tag &&
5157	    (block->type == LispBlockTag || block->type == LispBlockClosure)) {
5158	    lisp__data.block.block_ret = result == UNSPEC ? NIL : EVAL(result);
5159	    LispBlockUnwind(block);
5160	    BLOCKJUMP(block);
5161	}
5162	if (block->type == LispBlockClosure)
5163	    /* can use return-from only in the current function */
5164	    break;
5165    }
5166    LispDestroy("%s: no visible block named %s",
5167		STRFUN(builtin), STROBJ(name));
5168
5169    /*NOTREACHED*/
5170    return (NIL);
5171}
5172
5173static LispObj *
5174LispXReverse(LispBuiltin *builtin, int inplace)
5175/*
5176 nreverse sequence
5177 reverse sequence
5178 */
5179{
5180    long length;
5181    LispObj *list, *result = NIL;
5182
5183    LispObj *sequence;
5184
5185    sequence = ARGUMENT(0);
5186
5187    /* Do error checking for arrays and object type. */
5188    length = LispLength(sequence);
5189    if (length <= 1)
5190	return (sequence);
5191
5192    switch (XOBJECT_TYPE(sequence)) {
5193	case LispString_t: {
5194	    long i;
5195	    char *from, *to;
5196
5197	    from = THESTR(sequence) + length - 1;
5198	    if (inplace) {
5199		char temp;
5200
5201		CHECK_STRING_WRITABLE(sequence);
5202		to = THESTR(sequence);
5203		for (i = 0; i < length / 2; i++) {
5204		    temp = to[i];
5205		    to[i] = from[-i];
5206		    from[-i] = temp;
5207		}
5208		result = sequence;
5209	    }
5210	    else {
5211		to = LispMalloc(length + 1);
5212		to[length] = '\0';
5213		for (i = 0; i < length; i++)
5214		    to[i] = from[-i];
5215		result = STRING2(to);
5216	    }
5217	}   return (result);
5218	case LispCons_t:
5219	    if (inplace) {
5220		long i, j;
5221		LispObj *temp;
5222
5223		/* For large lists this can be very slow, but for small
5224		 * amounts of data, this avoid allocating a buffer to
5225		 * to store the CAR of the sequence. This is only done
5226		 * to not destroy the contents of a variable.
5227		 */
5228		for (i = 0, list = sequence;
5229		     i < (length + 1) / 2;
5230		     i++, list = CDR(list))
5231		    ;
5232		length /= 2;
5233		for (i = 0; i < length; i++, list = CDR(list)) {
5234		    for (j = length - i - 1, result = sequence;
5235			 j > 0;
5236			 j--, result = CDR(result))
5237			;
5238		    temp = CAR(list);
5239		    RPLACA(list, CAR(result));
5240		    RPLACA(result, temp);
5241		}
5242		return (sequence);
5243	    }
5244	    list = sequence;
5245	    break;
5246	case LispArray_t:
5247	    if (inplace) {
5248		sequence->data.array.list =
5249		    LispReverse(sequence->data.array.list);
5250		return (sequence);
5251	    }
5252	    list = sequence->data.array.list;
5253	    break;
5254	default:	/* LispNil_t */
5255	    return (result);
5256    }
5257
5258    {
5259	GC_ENTER();
5260	LispObj *cons;
5261
5262	result = cons = CONS(CAR(list), NIL);
5263	GC_PROTECT(result);
5264	for (list = CDR(list); CONSP(list); list = CDR(list)) {
5265	    RPLACD(cons, CONS(CAR(list), NIL));
5266	    cons = CDR(cons);
5267	}
5268	result = LispReverse(result);
5269
5270	GC_LEAVE();
5271    }
5272
5273    if (ARRAYP(sequence)) {
5274	list = result;
5275
5276	result = LispNew(list, NIL);
5277	result->type = LispArray_t;
5278	result->data.array.list = list;
5279	result->data.array.dim = sequence->data.array.dim;
5280	result->data.array.rank = sequence->data.array.rank;
5281	result->data.array.type = sequence->data.array.type;
5282	result->data.array.zero = sequence->data.array.zero;
5283    }
5284
5285    return (result);
5286}
5287
5288LispObj *
5289Lisp_Reverse(LispBuiltin *builtin)
5290/*
5291 reverse sequence
5292 */
5293{
5294    return (LispXReverse(builtin, 0));
5295}
5296
5297LispObj *
5298Lisp_Rplaca(LispBuiltin *builtin)
5299/*
5300 rplaca place value
5301 */
5302{
5303    LispObj *place, *value;
5304
5305    value = ARGUMENT(1);
5306    place = ARGUMENT(0);
5307
5308    CHECK_CONS(place);
5309    RPLACA(place, value);
5310
5311    return (place);
5312}
5313
5314LispObj *
5315Lisp_Rplacd(LispBuiltin *builtin)
5316/*
5317 rplacd place value
5318 */
5319{
5320    LispObj *place, *value;
5321
5322    value = ARGUMENT(1);
5323    place = ARGUMENT(0);
5324
5325    CHECK_CONS(place);
5326    RPLACD(place, value);
5327
5328    return (place);
5329}
5330
5331LispObj *
5332Lisp_Search(LispBuiltin *builtin)
5333/*
5334 search sequence1 sequence2 &key from-end test test-not key start1 start2 end1 end2
5335 */
5336{
5337    int code = 0, expect, value;
5338    long start1, start2, end1, end2, length1, length2, off1, off2, offset = -1;
5339    LispObj *cmp1, *cmp2, *list1 = NIL, *lambda;
5340    SeqInfo seq1, seq2;
5341
5342    LispObj *sequence1, *sequence2, *from_end, *test, *test_not,
5343	    *key, *ostart1, *ostart2, *oend1, *oend2;
5344
5345    oend2 = ARGUMENT(9);
5346    oend1 = ARGUMENT(8);
5347    ostart2 = ARGUMENT(7);
5348    ostart1 = ARGUMENT(6);
5349    key = ARGUMENT(5);
5350    test_not = ARGUMENT(4);
5351    test = ARGUMENT(3);
5352    from_end = ARGUMENT(2);
5353    sequence2 = ARGUMENT(1);
5354    sequence1 = ARGUMENT(0);
5355
5356    LispCheckSequenceStartEnd(builtin, sequence1, ostart1, oend1,
5357			      &start1, &end1, &length1);
5358    LispCheckSequenceStartEnd(builtin, sequence2, ostart2, oend2,
5359			      &start2, &end2, &length2);
5360
5361    /* Check for special conditions */
5362    if (start1 == end1)
5363	return (FIXNUM(end2));
5364    else if (start2 == end2)
5365	return (start1 == end1 ? FIXNUM(start2) : NIL);
5366
5367    CHECK_TEST();
5368
5369    if (from_end == UNSPEC)
5370	from_end = NIL;
5371
5372    SETSEQ(seq1, sequence1);
5373    SETSEQ(seq2, sequence2);
5374
5375    length1 = end1 - start1;
5376    length2 = end2 - start2;
5377
5378    /* update start of sequences */
5379    if (start1) {
5380	if (seq1.type == LispString_t)
5381	    seq1.data.string += start1;
5382	else {
5383	    for (cmp1 = seq1.data.list; start1; cmp1 = CDR(cmp1), --start1)
5384		;
5385	    seq1.data.list = cmp1;
5386	}
5387	end1 = length1;
5388    }
5389    if (start2) {
5390	if (seq2.type == LispString_t)
5391	    seq2.data.string += start2;
5392	else {
5393	    for (cmp2 = seq2.data.list; start2; cmp2 = CDR(cmp2), --start2)
5394		;
5395	    seq2.data.list = cmp2;
5396	}
5397	end2 = length2;
5398    }
5399
5400    /* easier case */
5401    if (from_end == NIL) {
5402	LispObj *list2 = NIL;
5403
5404	/* while a match is possible */
5405	while (end2 - start2 >= length1) {
5406
5407	    /* prepare to search */
5408	    off1 = 0;
5409	    off2 = start2;
5410	    if (seq1.type != LispString_t)
5411		list1 = seq1.data.list;
5412	    if (seq2.type != LispString_t)
5413		list2 = seq2.data.list;
5414
5415	    /* for every element that must match in sequence1 */
5416	    while (off1 < length1) {
5417		if (seq1.type == LispString_t)
5418		    cmp1 = SCHAR(seq1.data.string[off1]);
5419		else
5420		    cmp1 = CAR(list1);
5421		if (seq2.type == LispString_t)
5422		    cmp2 = SCHAR(seq2.data.string[off2]);
5423		else
5424		    cmp2 = CAR(list2);
5425		if (key != UNSPEC) {
5426		    cmp1 = APPLY1(key, cmp1);
5427		    cmp2 = APPLY1(key, cmp2);
5428		}
5429
5430		/* compare elements */
5431		value = FCOMPARE(lambda, cmp1, cmp2, code);
5432		if (value != expect)
5433		    break;
5434
5435		/* update offsets/sequence pointers */
5436		++off1;
5437		++off2;
5438		if (seq1.type != LispString_t)
5439		    list1 = CDR(list1);
5440		if (seq2.type != LispString_t)
5441		    list2 = CDR(list2);
5442	    }
5443
5444	    /* if everything matched */
5445	    if (off1 == end1) {
5446		offset = off2 - length1;
5447		break;
5448	    }
5449
5450	    /* update offset/sequence2 pointer */
5451	    ++start2;
5452	    if (seq2.type != LispString_t)
5453		seq2.data.list = CDR(seq2.data.list);
5454	}
5455    }
5456    else {
5457	/* allocate vector if required, only list2 requires it.
5458	 * list1 can be traversed forward */
5459	if (seq2.type != LispString_t) {
5460	    cmp2 = seq2.data.list;
5461	    seq2.data.vector = LispMalloc(sizeof(LispObj*) * length2);
5462	    for (off2 = 0; off2 < end2; off2++, cmp2 = CDR(cmp2))
5463		seq2.data.vector[off2] = CAR(cmp2);
5464	}
5465
5466	/* while a match is possible */
5467	while (end2 >= length1) {
5468
5469	    /* prepare to search */
5470	    off1 = 0;
5471	    off2 = end2 - length1;
5472	    if (seq1.type != LispString_t)
5473		list1 = seq1.data.list;
5474
5475	    /* for every element that must match in sequence1 */
5476	    while (off1 < end1) {
5477		if (seq1.type == LispString_t)
5478		    cmp1 = SCHAR(seq1.data.string[off1]);
5479		else
5480		    cmp1 = CAR(list1);
5481		if (seq2.type == LispString_t)
5482		    cmp2 = SCHAR(seq2.data.string[off2]);
5483		else
5484		    cmp2 = seq2.data.vector[off2];
5485		if (key != UNSPEC) {
5486		    cmp1 = APPLY1(key, cmp1);
5487		    cmp2 = APPLY1(key, cmp2);
5488		}
5489
5490		/* Compare elements */
5491		value = FCOMPARE(lambda, cmp1, cmp2, code);
5492		if (value != expect)
5493		    break;
5494
5495		/* Update offsets */
5496		++off1;
5497		++off2;
5498		if (seq1.type != LispString_t)
5499		    list1 = CDR(list1);
5500	    }
5501
5502	    /* If all elements matched */
5503	    if (off1 == end1) {
5504		offset = off2 - length1;
5505		break;
5506	    }
5507
5508	    /* Update offset */
5509	    --end2;
5510	}
5511
5512	if (seq2.type != LispString_t)
5513	    LispFree(seq2.data.vector);
5514    }
5515
5516    return (offset == -1 ? NIL : FIXNUM(offset));
5517}
5518
5519/*
5520 * ext::getenv
5521 */
5522LispObj *
5523Lisp_Setenv(LispBuiltin *builtin)
5524/*
5525 setenv name value &optional overwrite
5526 */
5527{
5528    char *name, *value;
5529
5530    LispObj *oname, *ovalue, *overwrite;
5531
5532    overwrite = ARGUMENT(2);
5533    ovalue = ARGUMENT(1);
5534    oname = ARGUMENT(0);
5535
5536    CHECK_STRING(oname);
5537    name = THESTR(oname);
5538
5539    CHECK_STRING(ovalue);
5540    value = THESTR(ovalue);
5541
5542    setenv(name, value, overwrite != UNSPEC && overwrite != NIL);
5543    value = getenv(name);
5544
5545    return (value ? STRING(value) : NIL);
5546}
5547
5548LispObj *
5549Lisp_Set(LispBuiltin *builtin)
5550/*
5551 set symbol value
5552 */
5553{
5554    LispAtom *atom;
5555    LispObj *symbol, *value;
5556
5557    value = ARGUMENT(1);
5558    symbol = ARGUMENT(0);
5559
5560    CHECK_SYMBOL(symbol);
5561    atom = symbol->data.atom;
5562    if (atom->dyn)
5563	LispSetVar(symbol, value);
5564    else if (atom->watch || !atom->a_object)
5565	LispSetAtomObjectProperty(atom, value);
5566    else {
5567	CHECK_CONSTANT(symbol);
5568	SETVALUE(atom, value);
5569    }
5570
5571    return (value);
5572}
5573
5574LispObj *
5575Lisp_SetDifference(LispBuiltin *builtin)
5576/*
5577 set-difference list1 list2 &key test test-not key
5578 */
5579{
5580    return (LispListSet(builtin, SETDIFFERENCE));
5581}
5582
5583LispObj *
5584Lisp_SetExclusiveOr(LispBuiltin *builtin)
5585/*
5586 set-exclusive-or list1 list2 &key test test-not key
5587 */
5588{
5589    return (LispListSet(builtin, SETEXCLUSIVEOR));
5590}
5591
5592LispObj *
5593Lisp_NsetExclusiveOr(LispBuiltin *builtin)
5594/*
5595 nset-exclusive-or list1 list2 &key test test-not key
5596 */
5597{
5598    return (LispListSet(builtin, NSETEXCLUSIVEOR));
5599}
5600
5601LispObj *
5602Lisp_SetQ(LispBuiltin *builtin)
5603/*
5604 setq &rest form
5605 */
5606{
5607    LispObj *result, *variable, *form;
5608
5609    form = ARGUMENT(0);
5610
5611    result = NIL;
5612    for (; CONSP(form); form = CDR(form)) {
5613	variable = CAR(form);
5614	CHECK_SYMBOL(variable);
5615	CHECK_CONSTANT(variable);
5616	form = CDR(form);
5617	if (!CONSP(form))
5618	    LispDestroy("%s: odd number of arguments", STRFUN(builtin));
5619	result = EVAL(CAR(form));
5620	LispSetVar(variable, result);
5621    }
5622
5623    return (result);
5624}
5625
5626LispObj *
5627Lisp_Psetq(LispBuiltin *builtin)
5628/*
5629 psetq &rest form
5630 */
5631{
5632    GC_ENTER();
5633    int base = gc__protect;
5634    LispObj *value, *symbol, *list, *form;
5635
5636    form = ARGUMENT(0);
5637
5638    /* parallel setq, first pass evaluate values and basic error checking */
5639    for (list = form; CONSP(list); list = CDR(list)) {
5640	symbol = CAR(list);
5641	CHECK_SYMBOL(symbol);
5642	list = CDR(list);
5643	if (!CONSP(list))
5644	    LispDestroy("%s: odd number of arguments", STRFUN(builtin));
5645	value = EVAL(CAR(list));
5646	GC_PROTECT(value);
5647    }
5648
5649    /* second pass, assign values */
5650    for (; CONSP(form); form = CDDR(form)) {
5651	symbol = CAR(form);
5652	CHECK_CONSTANT(symbol);
5653	LispSetVar(symbol, lisp__data.protect.objects[base++]);
5654    }
5655    GC_LEAVE();
5656
5657    return (NIL);
5658}
5659
5660LispObj *
5661Lisp_Setf(LispBuiltin *builtin)
5662/*
5663 setf &rest form
5664 */
5665{
5666    LispAtom *atom;
5667    LispObj *setf, *place, *value, *result = NIL, *data;
5668
5669    LispObj *form;
5670
5671    form = ARGUMENT(0);
5672
5673    for (; CONSP(form); form = CDR(form)) {
5674	place = CAR(form);
5675	form = CDR(form);
5676	if (!CONSP(form))
5677	    LispDestroy("%s: odd number of arguments", STRFUN(builtin));
5678	value = CAR(form);
5679
5680	if (!POINTERP(place))
5681	    goto invalid_place;
5682	if (XSYMBOLP(place)) {
5683	    CHECK_CONSTANT(place);
5684	    result = EVAL(value);
5685	    (void)LispSetVar(place, result);
5686	}
5687	else if (XCONSP(place)) {
5688	    /* it really should not be required to protect any object
5689	     * evaluated here, but is done for safety in case one of
5690	     * the evaluated forms returns data not gc protected, what
5691	     * could cause surprises if the object is garbage collected
5692	     * before finishing setf. */
5693	    GC_ENTER();
5694
5695	    setf = CAR(place);
5696	    if (!SYMBOLP(setf))
5697		goto invalid_place;
5698	    if (!CONSP(CDR(place)))
5699		goto invalid_place;
5700
5701	    value = EVAL(value);
5702	    GC_PROTECT(value);
5703
5704	    atom = setf->data.atom;
5705	    if (atom->a_defsetf == 0) {
5706		if (atom->a_defstruct &&
5707		    atom->property->structure.function >= 0) {
5708		    /* Use a default setf method for the structure field, as
5709		     * if this definition have been done
5710		     *	(defsetf THE-STRUCT-FIELD (struct) (value)
5711		     *	 `(lisp::struct-store 'THE-STRUCT-FIELD ,struct ,value))
5712		     */
5713		    place = CDR(place);
5714		    data = CAR(place);
5715		    if (CONSP(CDR(place)))
5716			goto invalid_place;
5717		    data = EVAL(data);
5718		    GC_PROTECT(data);
5719		    result = APPLY3(Ostruct_store, setf, data, value);
5720		    GC_LEAVE();
5721		    continue;
5722		}
5723		/* Must also expand macros */
5724		else if (atom->a_function &&
5725			 atom->property->fun.function->funtype == LispMacro) {
5726		    result = LispRunSetfMacro(atom, CDR(place), value);
5727		    continue;
5728		}
5729		goto invalid_place;
5730	    }
5731
5732	    place = CDR(place);
5733	    setf = setf->data.atom->property->setf;
5734	    if (SYMBOLP(setf)) {
5735		LispObj *arguments, *cons;
5736
5737		if (!CONSP(CDR(place))) {
5738		    arguments = EVAL(CAR(place));
5739		    GC_PROTECT(arguments);
5740		    result = APPLY2(setf, arguments, value);
5741		}
5742		else if (!CONSP(CDDR(place))) {
5743		    arguments = EVAL(CAR(place));
5744		    GC_PROTECT(arguments);
5745		    cons = EVAL(CADR(place));
5746		    GC_PROTECT(cons);
5747		    result = APPLY3(setf, arguments, cons, value);
5748		}
5749		else {
5750		    arguments = cons = CONS(EVAL(CAR(place)), NIL);
5751		    GC_PROTECT(arguments);
5752		    for (place = CDR(place); CONSP(place); place = CDR(place)) {
5753			RPLACD(cons, CONS(EVAL(CAR(place)), NIL));
5754			cons = CDR(cons);
5755		    }
5756		    RPLACD(cons, CONS(value, NIL));
5757		    result = APPLY(setf, arguments);
5758		}
5759	    }
5760	    else
5761		result = LispRunSetf(atom->property->salist, setf, place, value);
5762	    GC_LEAVE();
5763	}
5764	else
5765	    goto invalid_place;
5766    }
5767
5768    return (result);
5769invalid_place:
5770    LispDestroy("%s: %s is an invalid place", STRFUN(builtin), STROBJ(place));
5771    /*NOTREACHED*/
5772    return (NIL);
5773}
5774
5775LispObj *
5776Lisp_Psetf(LispBuiltin *builtin)
5777/*
5778 psetf &rest form
5779 */
5780{
5781    int base;
5782    GC_ENTER();
5783    LispAtom *atom;
5784    LispObj *setf, *place = NIL, *value, *data;
5785
5786    LispObj *form;
5787
5788    form = ARGUMENT(0);
5789
5790    /* parallel setf, first pass evaluate values and basic error checking */
5791    base = gc__protect;
5792    for (setf = form; CONSP(setf); setf = CDR(setf)) {
5793	if (!POINTERP(CAR(setf)))
5794	    goto invalid_place;
5795	setf = CDR(setf);
5796	if (!CONSP(setf))
5797	    LispDestroy("%s: odd number of arguments", STRFUN(builtin));
5798	value = EVAL(CAR(setf));
5799	GC_PROTECT(value);
5800    }
5801
5802    /* second pass, assign values */
5803    for (; CONSP(form); form = CDDR(form)) {
5804	place = CAR(form);
5805	value = lisp__data.protect.objects[base++];
5806
5807	if (XSYMBOLP(place)) {
5808	    CHECK_CONSTANT(place);
5809	    (void)LispSetVar(place, value);
5810	}
5811	else if (XCONSP(place)) {
5812	    LispObj *arguments, *cons;
5813	    int xbase = lisp__data.protect.length;
5814
5815	    setf = CAR(place);
5816	    if (!SYMBOLP(setf))
5817		goto invalid_place;
5818	    if (!CONSP(CDR(place)))
5819		goto invalid_place;
5820
5821	    atom = setf->data.atom;
5822	    if (atom->a_defsetf == 0) {
5823		if (atom->a_defstruct &&
5824		    atom->property->structure.function >= 0) {
5825		    place = CDR(place);
5826		    data = CAR(place);
5827		    if (CONSP(CDR(place)))
5828			goto invalid_place;
5829		    data = EVAL(data);
5830		    GC_PROTECT(data);
5831		    (void)APPLY3(Ostruct_store, setf, data, value);
5832		    lisp__data.protect.length = xbase;
5833		    continue;
5834		}
5835		else if (atom->a_function &&
5836			 atom->property->fun.function->funtype == LispMacro) {
5837		    (void)LispRunSetfMacro(atom, CDR(place), value);
5838		    lisp__data.protect.length = xbase;
5839		    continue;
5840		}
5841		goto invalid_place;
5842	    }
5843
5844	    place = CDR(place);
5845	    setf = setf->data.atom->property->setf;
5846	    if (SYMBOLP(setf)) {
5847		if (!CONSP(CDR(place))) {
5848		    arguments = EVAL(CAR(place));
5849		    GC_PROTECT(arguments);
5850		    (void)APPLY2(setf, arguments, value);
5851		}
5852		else if (!CONSP(CDDR(place))) {
5853		    arguments = EVAL(CAR(place));
5854		    GC_PROTECT(arguments);
5855		    cons = EVAL(CADR(place));
5856		    GC_PROTECT(cons);
5857		    (void)APPLY3(setf, arguments, cons, value);
5858		}
5859		else {
5860		    arguments = cons = CONS(EVAL(CAR(place)), NIL);
5861		    GC_PROTECT(arguments);
5862		    for (place = CDR(place); CONSP(place); place = CDR(place)) {
5863			RPLACD(cons, CONS(EVAL(CAR(place)), NIL));
5864			cons = CDR(cons);
5865		    }
5866		    RPLACD(cons, CONS(value, NIL));
5867		    (void)APPLY(setf, arguments);
5868		}
5869		lisp__data.protect.length = xbase;
5870	    }
5871	    else
5872		(void)LispRunSetf(atom->property->salist, setf, place, value);
5873	}
5874	else
5875	    goto invalid_place;
5876    }
5877    GC_LEAVE();
5878
5879    return (NIL);
5880invalid_place:
5881    LispDestroy("%s: %s is an invalid place", STRFUN(builtin), STROBJ(place));
5882    /*NOTREACHED*/
5883    return (NIL);
5884}
5885
5886LispObj *
5887Lisp_Sleep(LispBuiltin *builtin)
5888/*
5889 sleep seconds
5890 */
5891{
5892    long sec, msec;
5893    double value, dsec;
5894
5895    LispObj *seconds;
5896
5897    seconds = ARGUMENT(0);
5898
5899    value = -1.0;
5900    switch (OBJECT_TYPE(seconds)) {
5901	case LispFixnum_t:
5902	    value = FIXNUM_VALUE(seconds);
5903	    break;
5904	case LispDFloat_t:
5905	    value = DFLOAT_VALUE(seconds);
5906	    break;
5907	default:
5908	    break;
5909    }
5910
5911    if (value < 0.0 || value > MOST_POSITIVE_FIXNUM)
5912	LispDestroy("%s: %s is not a positive fixnum",
5913		    STRFUN(builtin), STROBJ(seconds));
5914
5915    msec = modf(value, &dsec) * 1e6;
5916    sec = dsec;
5917
5918    if (sec)
5919	sleep(sec);
5920    if (msec)
5921	usleep(msec);
5922
5923    return (NIL);
5924}
5925
5926/*
5927 *   This function is called recursively, but the contents of "list2" are
5928 * kept gc protected until it returns to LispSort. This is required partly
5929 * because the "gc protection logic" protects an object, not the contents
5930 * of the c pointer.
5931 */
5932static LispObj *
5933LispMergeSort(LispObj *list, LispObj *predicate, LispObj *key, int code)
5934{
5935    int protect;
5936    LispObj *list1, *list2, *left, *right, *result, *cons;
5937
5938    /* Check if list length is larger than 1 */
5939    if (!CONSP(list) || !CONSP(CDR(list)))
5940	return (list);
5941
5942    list1 = list2 = list;
5943    for (;;) {
5944	list = CDR(list);
5945	if (!CONSP(list))
5946	    break;
5947	list = CDR(list);
5948	if (!CONSP(list))
5949	    break;
5950	list2 = CDR(list2);
5951    }
5952    cons = list2;
5953    list2 = CDR(list2);
5954    RPLACD(cons, NIL);
5955
5956    protect = 0;
5957    if (lisp__data.protect.length + 2 >= lisp__data.protect.space)
5958	LispMoreProtects();
5959    lisp__data.protect.objects[lisp__data.protect.length++] = list2;
5960    list1 = LispMergeSort(list1, predicate, key, code);
5961    list2 = LispMergeSort(list2, predicate, key, code);
5962
5963    left = CAR(list1);
5964    right = CAR(list2);
5965    if (key != UNSPEC) {
5966	protect = lisp__data.protect.length;
5967	left = APPLY1(key, left);
5968	lisp__data.protect.objects[protect] = left;
5969	right = APPLY1(key, right);
5970	lisp__data.protect.objects[protect + 1] = right;
5971    }
5972
5973    result = NIL;
5974    for (;;) {
5975	if ((FCOMPARE(predicate, left, right, code)) == 0 &&
5976	    (FCOMPARE(predicate, right, left, code)) == 1) {
5977	    /* right is "smaller" */
5978	    if (result == NIL)
5979		result = list2;
5980	    else
5981		RPLACD(cons, list2);
5982	    cons = list2;
5983	    list2 = CDR(list2);
5984	    if (!CONSP(list2)) {
5985		RPLACD(cons, list1);
5986		break;
5987	    }
5988	    right = CAR(list2);
5989	    if (key != UNSPEC) {
5990		right = APPLY1(key, right);
5991		lisp__data.protect.objects[protect + 1] = right;
5992	    }
5993	}
5994	else {
5995	    /* left is "smaller" */
5996	    if (result == NIL)
5997		result = list1;
5998	    else
5999		RPLACD(cons, list1);
6000	    cons = list1;
6001	    list1 = CDR(list1);
6002	    if (!CONSP(list1)) {
6003		RPLACD(cons, list2);
6004		break;
6005	    }
6006	    left = CAR(list1);
6007	    if (key != UNSPEC) {
6008		left = APPLY1(key, left);
6009		lisp__data.protect.objects[protect] = left;
6010	    }
6011	}
6012    }
6013    if (key != UNSPEC)
6014	lisp__data.protect.length = protect;
6015
6016    return (result);
6017}
6018
6019/* XXX The first version made a copy of the list and then adjusted
6020 *     the CARs of the list. To minimize GC time now it is now doing
6021 *     the sort inplace. So, instead of writing just (sort variable)
6022 *     now it is required to write (setq variable (sort variable))
6023 *     if the variable should always keep all elements.
6024 */
6025LispObj *
6026Lisp_Sort(LispBuiltin *builtin)
6027/*
6028 sort sequence predicate &key key
6029 */
6030{
6031    GC_ENTER();
6032    int istring, code;
6033    long length;
6034    char *string;
6035
6036    LispObj *list, *work, *cons = NULL;
6037
6038    LispObj *sequence, *predicate, *key;
6039
6040    key = ARGUMENT(2);
6041    predicate = ARGUMENT(1);
6042    sequence = ARGUMENT(0);
6043
6044    length = LispLength(sequence);
6045    if (length < 2)
6046	return (sequence);
6047
6048    list = sequence;
6049    istring = XSTRINGP(sequence);
6050    if (istring) {
6051	CHECK_STRING_WRITABLE(sequence);
6052	/* Convert string to list */
6053	string = THESTR(sequence);
6054	work = cons = CONS(SCHAR(string[0]), NIL);
6055	GC_PROTECT(work);
6056	for (++string; *string; ++string) {
6057	    RPLACD(cons, CONS(SCHAR(*string), NIL));
6058	    cons = CDR(cons);
6059	}
6060    }
6061    else if (ARRAYP(list))
6062	work = list->data.array.list;
6063    else
6064	work = list;
6065
6066    FUNCTION_CHECK(predicate);
6067    code = FCODE(predicate);
6068    work = LispMergeSort(work, predicate, key, code);
6069
6070    if (istring) {
6071	/* Convert list to string */
6072	string = THESTR(sequence);
6073	for (; CONSP(work); ++string, work = CDR(work))
6074	    *string = SCHAR_VALUE(CAR(work));
6075    }
6076    else if (ARRAYP(list))
6077	list->data.array.list = work;
6078    else
6079	sequence = work;
6080    GC_LEAVE();
6081
6082    return (sequence);
6083}
6084
6085LispObj *
6086Lisp_Subseq(LispBuiltin *builtin)
6087/*
6088 subseq sequence start &optional end
6089 */
6090{
6091    long start, end, length, seqlength;
6092
6093    LispObj *sequence, *ostart, *oend, *result;
6094
6095    oend = ARGUMENT(2);
6096    ostart = ARGUMENT(1);
6097    sequence = ARGUMENT(0);
6098
6099    LispCheckSequenceStartEnd(builtin, sequence, ostart, oend,
6100			      &start, &end, &length);
6101
6102    seqlength = end - start;
6103
6104    if (sequence == NIL)
6105	result = NIL;
6106    else if (XSTRINGP(sequence)) {
6107	char *string = LispMalloc(seqlength + 1);
6108
6109	memcpy(string, THESTR(sequence) + start, seqlength);
6110	string[seqlength] = '\0';
6111	result = STRING2(string);
6112    }
6113    else {
6114	GC_ENTER();
6115	LispObj *object;
6116
6117	if (end > start) {
6118	    /* list or array */
6119	    int count;
6120	    LispObj *cons;
6121
6122	    if (ARRAYP(sequence))
6123		object = sequence->data.array.list;
6124	    else
6125		object = sequence;
6126	    /* goto first element to copy */
6127	    for (count = 0; count < start; count++, object = CDR(object))
6128		;
6129	    result = cons = CONS(CAR(object), NIL);
6130	    GC_PROTECT(result);
6131	    for (++count, object = CDR(object); count < end; count++,
6132		 object = CDR(object)) {
6133		RPLACD(cons, CONS(CAR(object), NIL));
6134		cons = CDR(cons);
6135	    }
6136	}
6137	else
6138	    result = NIL;
6139
6140	if (ARRAYP(sequence)) {
6141	    object = LispNew(NIL, NIL);
6142	    GC_PROTECT(object);
6143	    object->type = LispArray_t;
6144	    object->data.array.list = result;
6145	    object->data.array.dim = CONS(FIXNUM(seqlength), NIL);
6146	    object->data.array.rank = 1;
6147	    object->data.array.type = sequence->data.array.type;
6148	    object->data.array.zero = length == 0;
6149	    result = object;
6150	}
6151	GC_LEAVE();
6152    }
6153
6154    return (result);
6155}
6156
6157LispObj *
6158Lisp_Subsetp(LispBuiltin *builtin)
6159/*
6160 subsetp list1 list2 &key test test-not key
6161 */
6162{
6163    return (LispListSet(builtin, SUBSETP));
6164}
6165
6166
6167LispObj *
6168Lisp_Substitute(LispBuiltin *builtin)
6169/*
6170 substitute newitem olditem sequence &key from-end test test-not start end count key
6171 */
6172{
6173    return (LispDeleteRemoveXSubstitute(builtin, SUBSTITUTE, NONE));
6174}
6175
6176LispObj *
6177Lisp_SubstituteIf(LispBuiltin *builtin)
6178/*
6179 substitute-if newitem test sequence &key from-end start end count key
6180 */
6181{
6182    return (LispDeleteRemoveXSubstitute(builtin, SUBSTITUTE, IF));
6183}
6184
6185LispObj *
6186Lisp_SubstituteIfNot(LispBuiltin *builtin)
6187/*
6188 substitute-if-not newitem test sequence &key from-end start end count key
6189 */
6190{
6191    return (LispDeleteRemoveXSubstitute(builtin, SUBSTITUTE, IFNOT));
6192}
6193
6194LispObj *
6195Lisp_Symbolp(LispBuiltin *builtin)
6196/*
6197 symbolp object
6198 */
6199{
6200    LispObj *object;
6201
6202    object = ARGUMENT(0);
6203
6204    return (SYMBOLP(object) ? T : NIL);
6205}
6206
6207LispObj *
6208Lisp_SymbolFunction(LispBuiltin *builtin)
6209/*
6210 symbol-function symbol
6211 */
6212{
6213    LispObj *symbol;
6214
6215    symbol = ARGUMENT(0);
6216    CHECK_SYMBOL(symbol);
6217
6218    return (LispSymbolFunction(symbol));
6219}
6220
6221LispObj *
6222Lisp_SymbolName(LispBuiltin *builtin)
6223/*
6224 symbol-name symbol
6225 */
6226{
6227    LispObj *symbol;
6228
6229    symbol = ARGUMENT(0);
6230    CHECK_SYMBOL(symbol);
6231
6232    return (LispSymbolName(symbol));
6233}
6234
6235LispObj *
6236Lisp_SymbolPackage(LispBuiltin *builtin)
6237/*
6238 symbol-package symbol
6239 */
6240{
6241    LispObj *symbol;
6242
6243    symbol = ARGUMENT(0);
6244    CHECK_SYMBOL(symbol);
6245
6246    symbol = symbol->data.atom->package;
6247
6248    return (symbol ? symbol : NIL);
6249}
6250
6251LispObj *
6252Lisp_SymbolPlist(LispBuiltin *builtin)
6253/*
6254 symbol-plist symbol
6255 */
6256{
6257    LispObj *symbol;
6258
6259    symbol = ARGUMENT(0);
6260
6261    CHECK_SYMBOL(symbol);
6262
6263    return (symbol->data.atom->a_property ?
6264	    symbol->data.atom->property->properties : NIL);
6265}
6266
6267LispObj *
6268Lisp_SymbolValue(LispBuiltin *builtin)
6269/*
6270 symbol-value symbol
6271 */
6272{
6273    LispAtom *atom;
6274    LispObj *symbol;
6275
6276    symbol = ARGUMENT(0);
6277
6278    CHECK_SYMBOL(symbol);
6279    atom = symbol->data.atom;
6280    if (!atom->a_object || atom->property->value == UNBOUND) {
6281	if (atom->package == lisp__data.keyword)
6282	    return (symbol);
6283	LispDestroy("%s: the symbol %s has no value",
6284		    STRFUN(builtin), STROBJ(symbol));
6285    }
6286
6287    return (atom->dyn ? LispGetVar(symbol) : atom->property->value);
6288}
6289
6290LispObj *
6291Lisp_Tagbody(LispBuiltin *builtin)
6292/*
6293 tagbody &rest body
6294 */
6295{
6296    GC_ENTER();
6297    int stack, lex, length;
6298    LispObj *list, *body, *ptr, *tag, *labels, *map, **p_body;
6299    LispBlock *block;
6300
6301    body = ARGUMENT(0);
6302
6303    /* Save environment information */
6304    stack = lisp__data.stack.length;
6305    lex = lisp__data.env.lex;
6306    length = lisp__data.env.length;
6307
6308    /* Since the body may be large, and the code may iterate several
6309     * thousand times, it is not a bad idea to avoid checking all
6310     * elements of the body to verify if it is a tag. */
6311    for (labels = map = NIL, ptr = body; CONSP(ptr); ptr = CDR(ptr)) {
6312	tag = CAR(ptr);
6313	switch (OBJECT_TYPE(tag)) {
6314	    case LispNil_t:
6315	    case LispAtom_t:
6316	    case LispFixnum_t:
6317		/* Don't allow duplicated labels */
6318		for (list = labels; CONSP(list); list = CDDR(list)) {
6319		    if (CAR(list) == tag)
6320			LispDestroy("%s: tag %s specified more than once",
6321				    STRFUN(builtin), STROBJ(tag));
6322		}
6323		if (labels == NIL) {
6324		    labels = CONS(tag, CONS(NIL, NIL));
6325		    map = CDR(labels);
6326		    GC_PROTECT(labels);
6327		}
6328		else {
6329		    RPLACD(map, CONS(tag, CONS(NIL, NIL)));
6330		    map = CDDR(map);
6331		}
6332		break;
6333	    case LispCons_t:
6334		/* Restart point for tag */
6335		if (map != NIL && CAR(map) == NIL)
6336		    RPLACA(map, ptr);
6337		break;
6338	    default:
6339		break;
6340	}
6341    }
6342    /* Check for consecutive labels without code between them */
6343    for (ptr = labels; CONSP(ptr); ptr = CDDR(ptr)) {
6344	if (CADR(ptr) == NIL) {
6345	    for (map = CDDR(ptr); CONSP(map); map = CDDR(map)) {
6346		if (CADR(map) != NIL) {
6347		    RPLACA(CDR(ptr), CADR(map));
6348		    break;
6349		}
6350	    }
6351	}
6352    }
6353
6354    /* Initialize */
6355    list = body;
6356    p_body = &body;
6357    block = LispBeginBlock(NIL, LispBlockBody);
6358
6359    /* Loop */
6360    if (setjmp(block->jmp) != 0) {
6361	/* Restore environment */
6362	lisp__data.stack.length = stack;
6363	lisp__data.env.lex = lex;
6364	lisp__data.env.head = lisp__data.env.length = length;
6365
6366	tag = lisp__data.block.block_ret;
6367	for (ptr = labels; CONSP(ptr); ptr = CDDR(ptr)) {
6368	    map = CAR(ptr);
6369	    if (map == tag)
6370		break;
6371	}
6372
6373	if (!CONSP(ptr))
6374	    LispDestroy("%s: no such tag %s", STRFUN(builtin), STROBJ(tag));
6375
6376	*p_body = CADR(ptr);
6377    }
6378
6379    /* Execute code */
6380    for (; CONSP(body); body = CDR(body)) {
6381	LispObj *form = CAR(body);
6382
6383	if (CONSP(form))
6384	    EVAL(form);
6385    }
6386    /* If got here, (go) not called, else, labels will be candidate to gc
6387     * when GC_LEAVE() be called by the code in the bottom of the stack. */
6388    GC_LEAVE();
6389
6390    /* Finished */
6391    LispEndBlock(block);
6392
6393    /* Always return NIL */
6394    return (NIL);
6395}
6396
6397LispObj *
6398Lisp_The(LispBuiltin *builtin)
6399/*
6400 the value-type form
6401 */
6402{
6403    LispObj *value_type, *form;
6404
6405    form = ARGUMENT(1);
6406    value_type = ARGUMENT(0);
6407
6408    form = EVAL(form);
6409
6410    return (LispCoerce(builtin, form, value_type));
6411}
6412
6413LispObj *
6414Lisp_Throw(LispBuiltin *builtin)
6415/*
6416 throw tag result
6417 */
6418{
6419    unsigned blevel = lisp__data.block.block_level;
6420
6421    LispObj *tag, *result;
6422
6423    result = ARGUMENT(1);
6424    tag = ARGUMENT(0);
6425
6426    tag = EVAL(tag);
6427
6428    if (blevel == 0)
6429	LispDestroy("%s: not within a block", STRFUN(builtin));
6430
6431    while (blevel) {
6432	LispBlock *block = lisp__data.block.block[--blevel];
6433
6434	if (block->type == LispBlockCatch && tag == block->tag) {
6435	    lisp__data.block.block_ret = EVAL(result);
6436	    LispBlockUnwind(block);
6437	    BLOCKJUMP(block);
6438	}
6439    }
6440    LispDestroy("%s: %s is not a valid tag", STRFUN(builtin), STROBJ(tag));
6441
6442    /*NOTREACHED*/
6443    return (NIL);
6444}
6445
6446static LispObj *
6447LispTreeEqual(LispObj *left, LispObj *right, LispObj *test, int expect)
6448{
6449    LispObj *cmp_left, *cmp_right;
6450
6451    if ((OBJECT_TYPE(left)) ^ (OBJECT_TYPE(right)))
6452	return (NIL);
6453    if (CONSP(left)) {
6454	for (; CONSP(left) && CONSP(right);
6455	     left = CDR(left), right = CDR(right)) {
6456	    cmp_left = CAR(left);
6457	    cmp_right = CAR(right);
6458	    if ((OBJECT_TYPE(cmp_left)) ^ (OBJECT_TYPE(cmp_right)))
6459		return (NIL);
6460	    if (CONSP(cmp_left)) {
6461		if (LispTreeEqual(cmp_left, cmp_right, test, expect) == NIL)
6462		    return (NIL);
6463	    }
6464	    else {
6465		if (POINTERP(cmp_left) &&
6466		    (XQUOTEP(cmp_left) || XBACKQUOTEP(cmp_left))) {
6467		    cmp_left = cmp_left->data.quote;
6468		    cmp_right = cmp_right->data.quote;
6469		}
6470		else if (COMMAP(cmp_left)) {
6471		    cmp_left = cmp_left->data.comma.eval;
6472		    cmp_right = cmp_right->data.comma.eval;
6473		}
6474		if ((APPLY2(test, cmp_left, cmp_right) != NIL) != expect)
6475		    return (NIL);
6476	    }
6477	}
6478	if ((OBJECT_TYPE(left)) ^ (OBJECT_TYPE(right)))
6479	    return (NIL);
6480    }
6481
6482    if (POINTERP(left) && (XQUOTEP(left) || XBACKQUOTEP(left))) {
6483	left = left->data.quote;
6484	right = right->data.quote;
6485    }
6486    else if (COMMAP(left)) {
6487	left = left->data.comma.eval;
6488	right = right->data.comma.eval;
6489    }
6490
6491    return ((APPLY2(test, left, right) != NIL) == expect ? T : NIL);
6492}
6493
6494LispObj *
6495Lisp_TreeEqual(LispBuiltin *builtin)
6496/*
6497 tree-equal tree-1 tree-2 &key test test-not
6498 */
6499{
6500    int expect;
6501    LispObj *compare;
6502
6503    LispObj *tree_1, *tree_2, *test, *test_not;
6504
6505    test_not = ARGUMENT(3);
6506    test = ARGUMENT(2);
6507    tree_2 = ARGUMENT(1);
6508    tree_1 = ARGUMENT(0);
6509
6510    CHECK_TEST_0();
6511    if (test_not != UNSPEC) {
6512	expect = 0;
6513	compare = test_not;
6514    }
6515    else {
6516	if (test == UNSPEC)
6517	    test = Oeql;
6518	expect = 1;
6519	compare = test;
6520    }
6521
6522    return (LispTreeEqual(tree_1, tree_2, compare, expect));
6523}
6524
6525LispObj *
6526Lisp_Typep(LispBuiltin *builtin)
6527/*
6528 typep object type
6529 */
6530{
6531    LispObj *result = NULL;
6532
6533    LispObj *object, *type;
6534
6535    type = ARGUMENT(1);
6536    object = ARGUMENT(0);
6537
6538    if (SYMBOLP(type)) {
6539	Atom_id atom = ATOMID(type);
6540
6541	if (OBJECT_TYPE(object) == LispStruct_t)
6542	    result = ATOMID(CAR(object->data.struc.def)) == atom ? T : NIL;
6543	else if (type->data.atom->a_defstruct &&
6544		 type->data.atom->property->structure.function == STRUCT_NAME)
6545	    result = NIL;
6546	else if (atom == Snil)
6547	    result = object == NIL ? T : NIL;
6548	else if (atom == St)
6549	    result = object == T ? T : NIL;
6550	else if (atom == Satom)
6551	    result = !CONSP(object) ? T : NIL;
6552	else if (atom == Ssymbol)
6553	    result = SYMBOLP(object) || object == NIL || object == T ? T : NIL;
6554	else if (atom == Sinteger)
6555	    result = INTEGERP(object) ? T : NIL;
6556	else if (atom == Srational)
6557	    result = RATIONALP(object) ? T : NIL;
6558	else if (atom == Scons || atom == Slist)
6559	    result = CONSP(object) ? T : NIL;
6560	else if (atom == Sstring)
6561	    result = STRINGP(object) ? T : NIL;
6562	else if (atom == Scharacter)
6563	    result = SCHARP(object) ? T : NIL;
6564	else if (atom == Scomplex)
6565	    result = COMPLEXP(object) ? T : NIL;
6566	else if (atom == Svector || atom == Sarray)
6567	    result = ARRAYP(object) ? T : NIL;
6568	else if (atom == Skeyword)
6569	    result = KEYWORDP(object) ? T : NIL;
6570	else if (atom == Sfunction)
6571	    result = LAMBDAP(object) ? T : NIL;
6572	else if (atom == Spathname)
6573	    result = PATHNAMEP(object) ? T : NIL;
6574	else if (atom == Sopaque)
6575	    result = OPAQUEP(object) ? T : NIL;
6576    }
6577    else if (CONSP(type)) {
6578	if (OBJECT_TYPE(object) == LispStruct_t &&
6579	    SYMBOLP(CAR(type)) && ATOMID(CAR(type)) == Sstruct &&
6580	    SYMBOLP(CAR(CDR(type))) && CDR(CDR(type)) == NIL) {
6581	    result = ATOMID(CAR(object->data.struc.def)) ==
6582		     ATOMID(CAR(CDR(type))) ? T : NIL;
6583	}
6584    }
6585    else if (type == NIL)
6586	result = object == NIL ? T : NIL;
6587    else if (type == T)
6588	result = object == T ? T : NIL;
6589    if (result == NULL)
6590	LispDestroy("%s: bad type specification %s",
6591		    STRFUN(builtin), STROBJ(type));
6592
6593    return (result);
6594}
6595
6596LispObj *
6597Lisp_Union(LispBuiltin *builtin)
6598/*
6599 union list1 list2 &key test test-not key
6600 */
6601{
6602    return (LispListSet(builtin, UNION));
6603}
6604
6605LispObj *
6606Lisp_Nunion(LispBuiltin *builtin)
6607/*
6608 nunion list1 list2 &key test test-not key
6609 */
6610{
6611    return (LispListSet(builtin, NUNION));
6612}
6613
6614LispObj *
6615Lisp_Unless(LispBuiltin *builtin)
6616/*
6617 unless test &rest body
6618 */
6619{
6620    LispObj *result, *test, *body;
6621
6622    body = ARGUMENT(1);
6623    test = ARGUMENT(0);
6624
6625    result = NIL;
6626    test = EVAL(test);
6627    RETURN_COUNT = 0;
6628    if (test == NIL) {
6629	for (; CONSP(body); body = CDR(body))
6630	    result = EVAL(CAR(body));
6631    }
6632
6633    return (result);
6634}
6635
6636/*
6637 * ext::until
6638 */
6639LispObj *
6640Lisp_Until(LispBuiltin *builtin)
6641/*
6642 until test &rest body
6643 */
6644{
6645    LispObj *result, *test, *body, *prog;
6646
6647    body = ARGUMENT(1);
6648    test = ARGUMENT(0);
6649
6650    result = NIL;
6651    for (;;) {
6652	if ((result = EVAL(test)) == NIL) {
6653	    for (prog = body; CONSP(prog); prog = CDR(prog))
6654		(void)EVAL(CAR(prog));
6655	}
6656	else
6657	    break;
6658    }
6659
6660    return (result);
6661}
6662
6663LispObj *
6664Lisp_UnwindProtect(LispBuiltin *builtin)
6665/*
6666 unwind-protect protect &rest cleanup
6667 */
6668{
6669    LispObj *result, **presult = &result;
6670    int did_jump, *pdid_jump = &did_jump, destroyed;
6671    LispBlock *block;
6672
6673    LispObj *protect, *cleanup, **pcleanup = &cleanup;
6674
6675    cleanup = ARGUMENT(1);
6676    protect = ARGUMENT(0);
6677
6678    /* run protected code */
6679    *presult = NIL;
6680    *pdid_jump = 1;
6681    block = LispBeginBlock(NIL, LispBlockProtect);
6682    if (setjmp(block->jmp) == 0) {
6683	*presult = EVAL(protect);
6684	*pdid_jump = 0;
6685    }
6686    LispEndBlock(block);
6687    if (!lisp__data.destroyed && *pdid_jump)
6688	*presult = lisp__data.block.block_ret;
6689
6690    destroyed = lisp__data.destroyed;
6691    lisp__data.destroyed = 0;
6692
6693    /* run cleanup, unprotected code */
6694    if (CONSP(*pcleanup))
6695	for (; CONSP(cleanup); cleanup = CDR(cleanup))
6696	    (void)EVAL(CAR(cleanup));
6697
6698    if (destroyed) {
6699	/* in case there is another unwind-protect */
6700	LispBlockUnwind(NULL);
6701	/* if not, just return to the toplevel */
6702	lisp__data.destroyed = 1;
6703	LispDestroy(".");
6704    }
6705
6706    return (result);
6707}
6708
6709static LispObj *
6710LispValuesList(LispBuiltin *builtin, int check_list)
6711{
6712    long i, count;
6713    LispObj *result;
6714
6715    LispObj *list;
6716
6717    list = ARGUMENT(0);
6718
6719    count = LispLength(list) - 1;
6720
6721    if (count >= 0) {
6722	result = CAR(list);
6723	if ((RETURN_CHECK(count)) != count)
6724	    LispDestroy("%s: too many values", STRFUN(builtin));
6725	RETURN_COUNT = count;
6726	for (i = 0, list = CDR(list); count && CONSP(list);
6727	     count--, i++, list = CDR(list))
6728	    RETURN(i) = CAR(list);
6729	if (check_list) {
6730	    CHECK_LIST(list);
6731	}
6732    }
6733    else {
6734	RETURN_COUNT = -1;
6735	result = NIL;
6736    }
6737
6738    return (result);
6739}
6740
6741LispObj *
6742Lisp_Values(LispBuiltin *builtin)
6743/*
6744 values &rest objects
6745 */
6746{
6747    return (LispValuesList(builtin, 0));
6748}
6749
6750LispObj *
6751Lisp_ValuesList(LispBuiltin *builtin)
6752/*
6753 values-list list
6754 */
6755{
6756    return (LispValuesList(builtin, 1));
6757}
6758
6759LispObj *
6760Lisp_Vector(LispBuiltin *builtin)
6761/*
6762 vector &rest objects
6763 */
6764{
6765    LispObj *objects;
6766
6767    objects = ARGUMENT(0);
6768
6769    return (VECTOR(objects));
6770}
6771
6772LispObj *
6773Lisp_When(LispBuiltin *builtin)
6774/*
6775 when test &rest body
6776 */
6777{
6778    LispObj *result, *test, *body;
6779
6780    body = ARGUMENT(1);
6781    test = ARGUMENT(0);
6782
6783    result = NIL;
6784    test = EVAL(test);
6785    RETURN_COUNT = 0;
6786    if (test != NIL) {
6787	for (; CONSP(body); body = CDR(body))
6788	    result = EVAL(CAR(body));
6789    }
6790
6791    return (result);
6792}
6793
6794/*
6795 * ext::while
6796 */
6797LispObj *
6798Lisp_While(LispBuiltin *builtin)
6799/*
6800 while test &rest body
6801 */
6802{
6803    LispObj *test, *body, *prog;
6804
6805    body = ARGUMENT(1);
6806    test = ARGUMENT(0);
6807
6808    for (;;) {
6809	if (EVAL(test) != NIL) {
6810	    for (prog = body; CONSP(prog); prog = CDR(prog))
6811		(void)EVAL(CAR(prog));
6812	}
6813	else
6814	    break;
6815    }
6816
6817    return (NIL);
6818}
6819
6820/*
6821 * ext::unsetenv
6822 */
6823LispObj *
6824Lisp_Unsetenv(LispBuiltin *builtin)
6825/*
6826 unsetenv name
6827 */
6828{
6829    char *name;
6830
6831    LispObj *oname;
6832
6833    oname = ARGUMENT(0);
6834
6835    CHECK_STRING(oname);
6836    name = THESTR(oname);
6837
6838    unsetenv(name);
6839
6840    return (NIL);
6841}
6842
6843LispObj *
6844Lisp_XeditEltStore(LispBuiltin *builtin)
6845/*
6846 lisp::elt-store sequence index value
6847 */
6848{
6849    int length, offset;
6850
6851    LispObj *sequence, *oindex, *value;
6852
6853    value = ARGUMENT(2);
6854    oindex = ARGUMENT(1);
6855    sequence = ARGUMENT(0);
6856
6857    CHECK_INDEX(oindex);
6858    offset = FIXNUM_VALUE(oindex);
6859    length = LispLength(sequence);
6860
6861    if (offset >= length)
6862	LispDestroy("%s: index %d too large for sequence length %d",
6863		    STRFUN(builtin), offset, length);
6864
6865    if (STRINGP(sequence)) {
6866	int ch;
6867
6868	CHECK_STRING_WRITABLE(sequence);
6869	CHECK_SCHAR(value);
6870	ch = SCHAR_VALUE(value);
6871	if (ch < 0 || ch > 255)
6872	    LispDestroy("%s: cannot represent character %d",
6873			STRFUN(builtin), ch);
6874	THESTR(sequence)[offset] = ch;
6875    }
6876    else {
6877	if (ARRAYP(sequence))
6878	    sequence = sequence->data.array.list;
6879
6880	for (; offset > 0; offset--, sequence = CDR(sequence))
6881	    ;
6882	RPLACA(sequence, value);
6883    }
6884
6885    return (value);
6886}
6887
6888LispObj *
6889Lisp_XeditPut(LispBuiltin *builtin)
6890/*
6891 lisp::put symbol indicator value
6892 */
6893{
6894    LispObj *symbol, *indicator, *value;
6895
6896    value = ARGUMENT(2);
6897    indicator = ARGUMENT(1);
6898    symbol = ARGUMENT(0);
6899
6900    CHECK_SYMBOL(symbol);
6901
6902    return (CAR(LispPutAtomProperty(symbol->data.atom, indicator, value)));
6903}
6904
6905LispObj *
6906Lisp_XeditSetSymbolPlist(LispBuiltin *builtin)
6907/*
6908 lisp::set-symbol-plist symbol list
6909 */
6910{
6911    LispObj *symbol, *list;
6912
6913    list = ARGUMENT(1);
6914    symbol = ARGUMENT(0);
6915
6916    CHECK_SYMBOL(symbol);
6917
6918    return (LispReplaceAtomPropertyList(symbol->data.atom, list));
6919}
6920
6921LispObj *
6922Lisp_XeditVectorStore(LispBuiltin *builtin)
6923/*
6924 lisp::vector-store array &rest values
6925 */
6926{
6927    LispObj *value, *list, *object;
6928    long rank, count, sequence, offset, accum;
6929
6930    LispObj *array, *values;
6931
6932    values = ARGUMENT(1);
6933    array = ARGUMENT(0);
6934
6935    /* check for errors */
6936    for (rank = 0, list = values;
6937	 CONSP(list) && CONSP(CDR(list));
6938	 list = CDR(list), rank++) {
6939	CHECK_INDEX(CAR(values));
6940    }
6941
6942    if (rank == 0)
6943	LispDestroy("%s: too few subscripts", STRFUN(builtin));
6944    value = CAR(list);
6945
6946    if (STRINGP(array) && rank == 1) {
6947	long ch;
6948	long length = STRLEN(array);
6949	long offset = FIXNUM_VALUE(CAR(values));
6950
6951	CHECK_SCHAR(value);
6952	CHECK_STRING_WRITABLE(array);
6953	ch = SCHAR_VALUE(value);
6954	if (offset >= length)
6955	    LispDestroy("%s: index %ld too large for sequence length %ld",
6956			STRFUN(builtin), offset, length);
6957
6958	if (ch < 0 || ch > 255)
6959	    LispDestroy("%s: cannot represent character %ld",
6960			STRFUN(builtin), ch);
6961	THESTR(array)[offset] = ch;
6962
6963	return (value);
6964    }
6965
6966    CHECK_ARRAY(array);
6967    if (rank != array->data.array.rank)
6968	LispDestroy("%s: too %s subscripts", STRFUN(builtin),
6969		    rank < array->data.array.rank ? "few" : "many");
6970
6971    for (list = values, object = array->data.array.dim;
6972	 CONSP(CDR(list));
6973	 list = CDR(list), object = CDR(object)) {
6974	if (FIXNUM_VALUE(CAR(list)) >= FIXNUM_VALUE(CAR(object)))
6975	    LispDestroy("%s: %ld is out of range, index %ld",
6976			STRFUN(builtin),
6977			FIXNUM_VALUE(CAR(list)),
6978			FIXNUM_VALUE(CAR(object)));
6979    }
6980
6981    for (count = sequence = 0, list = values;
6982	 CONSP(CDR(list));
6983	 list = CDR(list), sequence++) {
6984	for (offset = 0, object = array->data.array.dim;
6985	     offset < sequence; object = CDR(object), offset++)
6986	    ;
6987	for (accum = 1, object = CDR(object); CONSP(object);
6988	     object = CDR(object))
6989	    accum *= FIXNUM_VALUE(CAR(object));
6990	count += accum * FIXNUM_VALUE(CAR(list));
6991    }
6992
6993    for (array = array->data.array.list; count > 0; array = CDR(array), count--)
6994	;
6995
6996    RPLACA(array, value);
6997
6998    return (value);
6999}
7000
7001LispObj *
7002Lisp_XeditDocumentationStore(LispBuiltin *builtin)
7003/*
7004 lisp::documentation-store symbol type string
7005 */
7006{
7007    LispDocType_t doc_type;
7008
7009    LispObj *symbol, *type, *string;
7010
7011    string = ARGUMENT(2);
7012    type = ARGUMENT(1);
7013    symbol = ARGUMENT(0);
7014
7015    CHECK_SYMBOL(symbol);
7016
7017    /* type is checked in LispDocumentationType() */
7018    doc_type = LispDocumentationType(builtin, type);
7019
7020    if (string == NIL)
7021	/* allow explicitly releasing memory used for documentation */
7022	LispRemDocumentation(symbol, doc_type);
7023    else {
7024	CHECK_STRING(string);
7025	LispAddDocumentation(symbol, string, doc_type);
7026    }
7027
7028    return (string);
7029}
7030