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