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