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