source: trunk/abcl/src/org/armedbear/lisp/Primitives.java

Last change on this file was 15734, checked in by Mark Evenson, 8 months ago

Implement vector-to-vector REPLACE as a primitive
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 197.8 KB
Line 
1/*
2 * Primitives.java
3 *
4 * Copyright (C) 2002-2007 Peter Graves
5 * Copyright (C) 2011 Erik Huelsmann
6 * $Id: Primitives.java 15734 2023-09-01 06:28:20Z mevenson $
7 *
8 * This program is free software; you can redistribute it and/or
9 * modify it under the terms of the GNU General Public License
10 * as published by the Free Software Foundation; either version 2
11 * of the License, or (at your option) any later version.
12 *
13 * This program is distributed in the hope that it will be useful,
14 * but WITHOUT ANY WARRANTY; without even the implied warranty of
15 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 * GNU General Public License for more details.
17 *
18 * You should have received a copy of the GNU General Public License
19 * along with this program; if not, write to the Free Software
20 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
21 *
22 * As a special exception, the copyright holders of this library give you
23 * permission to link this library with independent modules to produce an
24 * executable, regardless of the license terms of these independent
25 * modules, and to copy and distribute the resulting executable under
26 * terms of your choice, provided that you also meet, for each linked
27 * independent module, the terms and conditions of the license of that
28 * module.  An independent module is a module which is not derived from
29 * or based on this library.  If you modify this library, you may extend
30 * this exception to your version of the library, but you are not
31 * obligated to do so.  If you do not wish to do so, delete this
32 * exception statement from your version.
33 */
34
35package org.armedbear.lisp;
36
37import static org.armedbear.lisp.Lisp.*;
38
39import java.io.Serializable;
40import java.math.BigInteger;
41import java.util.ArrayList;
42import org.armedbear.lisp.util.Finalizer;
43
44public final class Primitives {
45    // ### *
46    public static final Primitive MULTIPLY = new pf_multiply();
47    private static final class pf_multiply extends Primitive {
48        pf_multiply() {
49            super(Symbol.STAR, "&rest numbers");
50        }
51
52        @Override
53        public LispObject execute() {
54            return Fixnum.ONE;
55        }
56        @Override
57        public LispObject execute(LispObject arg) {
58            if (arg.numberp())
59                return arg;
60            return type_error(arg, Symbol.NUMBER);
61        }
62        @Override
63        public LispObject execute(LispObject first, LispObject second)
64
65        {
66            return first.multiplyBy(second);
67        }
68        @Override
69        public LispObject execute(LispObject[] args) {
70            LispObject result = Fixnum.ONE;
71            for (int i = 0; i < args.length; i++)
72                result = result.multiplyBy(args[i]);
73            return result;
74        }
75    };
76
77    // ### /
78    public static final Primitive DIVIDE = new pf_divide();
79    private static final class pf_divide extends Primitive {
80        pf_divide() {
81            super(Symbol.SLASH, "numerator &rest denominators");
82        }
83
84        @Override
85        public LispObject execute() {
86            return error(new WrongNumberOfArgumentsException(this, 1, -1));
87        }
88        @Override
89        public LispObject execute(LispObject arg) {
90            return Fixnum.ONE.divideBy(arg);
91        }
92        @Override
93        public LispObject execute(LispObject first, LispObject second)
94
95        {
96            return first.divideBy(second);
97        }
98        @Override
99        public LispObject execute(LispObject[] args) {
100            LispObject result = args[0];
101            for (int i = 1; i < args.length; i++)
102                result = result.divideBy(args[i]);
103            return result;
104        }
105    };
106
107    // ### min
108    public static final Primitive MIN = new pf_min();
109    private static final class pf_min extends Primitive {
110        pf_min() {
111            super(Symbol.MIN, "&rest reals");
112        }
113
114        @Override
115        public LispObject execute() {
116            return error(new WrongNumberOfArgumentsException(this, 1, -1));
117        }
118        @Override
119        public LispObject execute(LispObject arg) {
120            if (arg.realp())
121                return arg;
122            return type_error(arg, Symbol.REAL);
123        }
124        @Override
125        public LispObject execute(LispObject first, LispObject second)
126
127        {
128            return first.isLessThan(second) ? first : second;
129        }
130        @Override
131        public LispObject execute(LispObject[] args) {
132            LispObject result = args[0];
133            if (!result.realp())
134                type_error(result, Symbol.REAL);
135            for (int i = 1; i < args.length; i++) {
136                if (args[i].isLessThan(result))
137                    result = args[i];
138            }
139            return result;
140        }
141    };
142
143    // ### max
144    public static final Primitive MAX = new pf_max();
145    private static final class pf_max extends Primitive {
146        pf_max() {
147            super(Symbol.MAX, "&rest reals");
148        }
149
150        @Override
151        public LispObject execute() {
152            return error(new WrongNumberOfArgumentsException(this, 1, -1));
153        }
154        @Override
155        public LispObject execute(LispObject arg) {
156            if (arg.realp())
157                return arg;
158            return type_error(arg, Symbol.REAL);
159        }
160        @Override
161        public LispObject execute(LispObject first, LispObject second)
162
163        {
164            return first.isGreaterThan(second) ? first : second;
165        }
166        @Override
167        public LispObject execute(LispObject[] args) {
168            LispObject result = args[0];
169            if (!result.realp())
170                type_error(result, Symbol.REAL);
171            for (int i = 1; i < args.length; i++) {
172                if (args[i].isGreaterThan(result))
173                    result = args[i];
174            }
175            return result;
176        }
177    };
178
179    // ### identity
180    private static final Primitive IDENTITY = new pf_identity();
181    private static final class pf_identity extends Primitive {
182        pf_identity() {
183            super(Symbol.IDENTITY, "object");
184        }
185
186        @Override
187        public LispObject execute(LispObject arg) {
188            return arg;
189        }
190    };
191
192    // ### compiled-function-p
193    private static final Primitive COMPILED_FUNCTION_P = new pf_compiled_function_p();
194    private static final class pf_compiled_function_p extends Primitive {
195        pf_compiled_function_p() {
196            super(Symbol.COMPILED_FUNCTION_P, "object");
197        }
198
199        @Override
200        public LispObject execute(LispObject arg) {
201            return arg.typep(Symbol.COMPILED_FUNCTION);
202        }
203    };
204
205    // ### compiled-lisp-function-p
206    private static final Primitive COMPILED_LISP_FUNCTION_P =
207        new pf_compiled_lisp_function_p();
208    private static final class pf_compiled_lisp_function_p extends Primitive {
209        pf_compiled_lisp_function_p() {
210            super(Symbol.COMPILED_LISP_FUNCTION_P, "object");
211        }
212
213        @Override
214        public LispObject execute(LispObject arg) {
215            return (arg instanceof CompiledClosure
216                    || arg instanceof CompiledPrimitive) ? T : NIL;
217        }
218    }
219
220    // ### consp
221    private static final Primitive CONSP = new pf_consp();
222    private static final class pf_consp extends Primitive {
223        pf_consp() {
224            super(Symbol.CONSP, "object");
225        }
226
227        @Override
228        public LispObject execute(LispObject arg) {
229            return arg instanceof Cons ? T : NIL;
230        }
231    };
232
233    // ### listp
234    private static final Primitive LISTP = new pf_listp();
235    private static final class pf_listp extends Primitive {
236        pf_listp() {
237            super(Symbol.LISTP, "object");
238        }
239
240        @Override
241        public LispObject execute(LispObject arg) {
242            return arg.LISTP();
243        }
244    };
245
246    // ### abs
247    private static final Primitive ABS = new pf_abs();
248    private static final class pf_abs extends Primitive {
249        pf_abs() {
250            super(Symbol.ABS, "number");
251        }
252
253        @Override
254        public LispObject execute(LispObject arg) {
255            return arg.ABS();
256        }
257    };
258
259    // ### arrayp
260    private static final Primitive ARRAYP = new pf_arrayp();
261    private static final class pf_arrayp extends Primitive {
262        pf_arrayp() {
263            super(Symbol.ARRAYP, "object");
264        }
265
266        @Override
267        public LispObject execute(LispObject arg) {
268            return arg instanceof AbstractArray ? T : NIL;
269        }
270    };
271
272    // ### array-has-fill-pointer-p
273    private static final Primitive ARRAY_HAS_FILL_POINTER_P = new pf_array_has_fill_pointer_p();
274    private static final class pf_array_has_fill_pointer_p extends Primitive {
275        pf_array_has_fill_pointer_p() {
276            super(Symbol.ARRAY_HAS_FILL_POINTER_P, "array");
277        }
278
279        @Override
280        public LispObject execute(LispObject arg) {
281            return checkArray(arg).hasFillPointer() ? T : NIL;
282        }
283    };
284
285    // ### vectorp
286    private static final Primitive VECTORP = new pf_vectorp();
287    private static final class pf_vectorp extends Primitive {
288        pf_vectorp() {
289            super(Symbol.VECTORP, "object");
290        }
291
292        @Override
293        public LispObject execute(LispObject arg) {
294            return arg.VECTORP();
295        }
296    };
297
298    // ### simple-vector-p
299    private static final Primitive SIMPLE_VECTOR_P = new pf_simple_vector_p();
300    private static final class pf_simple_vector_p extends Primitive {
301        pf_simple_vector_p() {
302            super(Symbol.SIMPLE_VECTOR_P, "object");
303        }
304
305        @Override
306        public LispObject execute(LispObject arg) {
307            return arg instanceof SimpleVector ? T : NIL;
308        }
309    };
310
311    // ### bit-vector-p
312    private static final Primitive BIT_VECTOR_P = new pf_bit_vector_p();
313    private static final class pf_bit_vector_p extends Primitive {
314        pf_bit_vector_p() {
315            super(Symbol.BIT_VECTOR_P, "object");
316        }
317
318        @Override
319        public LispObject execute(LispObject arg) {
320            return arg instanceof AbstractBitVector ? T : NIL;
321        }
322    };
323
324    // ### simple-bit-vector-p
325    private static final Primitive SIMPLE_BIT_VECTOR_P = new pf_simple_bit_vector_p();
326    private static final class pf_simple_bit_vector_p extends Primitive {
327        pf_simple_bit_vector_p() {
328            super(Symbol.SIMPLE_BIT_VECTOR_P, "object");
329        }
330
331        @Override
332        public LispObject execute(LispObject arg) {
333            return arg.typep(Symbol.SIMPLE_BIT_VECTOR);
334        }
335    };
336
337    // ### %eval
338    private static final Primitive _EVAL = new pf__eval();
339    private static final class pf__eval extends Primitive {
340        pf__eval() {
341            super("%eval", PACKAGE_SYS, false, "form");
342        }
343
344        @Override
345        public LispObject execute(LispObject arg) {
346            return eval(arg, new Environment(), LispThread.currentThread());
347        }
348    };
349
350    // ### eq
351    private static final Primitive EQ = new pf_eq();
352    private static final class pf_eq extends Primitive {
353        pf_eq() {
354            super(Symbol.EQ, "x y");
355        }
356
357        @Override
358        public LispObject execute(LispObject first, LispObject second)
359
360        {
361            return first == second ? T : NIL;
362        }
363    };
364
365    // ### eql
366    static final Primitive EQL = new pf_eql();
367    private static final class pf_eql extends Primitive {
368        pf_eql() {
369            super(Symbol.EQL, "x y");
370        }
371
372        @Override
373        public LispObject execute(LispObject first, LispObject second)
374
375        {
376            return first.eql(second) ? T : NIL;
377        }
378    };
379
380    // ### equal
381    private static final Primitive EQUAL = new pf_equal();
382    private static final class pf_equal extends Primitive {
383        pf_equal() {
384            super(Symbol.EQUAL, "x y");
385        }
386
387        @Override
388        public LispObject execute(LispObject first, LispObject second)
389
390        {
391            return first.equal(second) ? T : NIL;
392        }
393    };
394
395    // ### equalp
396    private static final Primitive EQUALP = new pf_equalp();
397    private static final class pf_equalp extends Primitive {
398        pf_equalp() {
399            super(Symbol.EQUALP, "x y");
400        }
401
402        @Override
403        public LispObject execute(LispObject first, LispObject second)
404
405        {
406            return first.equalp(second) ? T : NIL;
407        }
408    };
409
410    // ### values
411    public static final Primitive VALUES = new pf_values();
412    private static final class pf_values extends Primitive {
413        pf_values() {
414            super(Symbol.VALUES, "&rest object");
415        }
416
417        @Override
418        public LispObject execute() {
419            return LispThread.currentThread().setValues();
420        }
421        @Override
422        public LispObject execute(LispObject arg) {
423            return LispThread.currentThread().setValues(arg);
424        }
425        @Override
426        public LispObject execute(LispObject first, LispObject second) {
427            return LispThread.currentThread().setValues(first, second);
428        }
429        @Override
430        public LispObject execute(LispObject first, LispObject second,
431                                  LispObject third) {
432            return LispThread.currentThread().setValues(first, second, third);
433        }
434        @Override
435        public LispObject execute(LispObject first, LispObject second,
436                                  LispObject third, LispObject fourth) {
437            return LispThread.currentThread().setValues(first, second, third,
438                    fourth);
439        }
440        @Override
441        public LispObject execute(LispObject[] args) {
442            return LispThread.currentThread().setValues(args);
443        }
444    };
445
446    // ### values-list list => element*
447    // Returns the elements of the list as multiple values.
448    private static final Primitive VALUES_LIST = new pf_values_list();
449    private static final class pf_values_list extends Primitive {
450        pf_values_list() {
451            super(Symbol.VALUES_LIST, "list");
452        }
453
454        @Override
455        public LispObject execute(LispObject arg) {
456            if (arg == NIL)
457                return LispThread.currentThread().setValues();
458            if (arg.cdr() == NIL)
459                return arg.car();
460            return LispThread.currentThread().setValues(arg.copyToArray());
461        }
462    };
463
464    // ### cons
465    private static final Primitive CONS = new pf_cons();
466    private static final class pf_cons extends Primitive {
467        pf_cons() {
468            super(Symbol.CONS, "object-1 object-2");
469        }
470
471        @Override
472        public LispObject execute(LispObject first, LispObject second)
473
474        {
475            return new Cons(first, second);
476        }
477    };
478
479    // ### length
480    private static final Primitive LENGTH = new pf_length();
481    private static final class pf_length extends Primitive {
482        pf_length() {
483            super("%LENGTH", PACKAGE_SYS, false, "sequence");
484        }
485
486        @Override
487        public LispObject execute(LispObject arg) {
488            return arg.LENGTH();
489        }
490    };
491
492    // ### elt
493    private static final Primitive ELT = new pf_elt();
494    private static final class pf_elt extends Primitive {
495        pf_elt() {
496            super("%ELT", PACKAGE_SYS, false, "sequence index");
497        }
498
499        @Override
500        public LispObject execute(LispObject first, LispObject second)
501
502        {
503            return first.elt(Fixnum.getValue(second));
504        }
505    };
506
507    // ### atom
508    private static final Primitive ATOM = new pf_atom();
509    private static final class pf_atom extends Primitive {
510        pf_atom() {
511            super(Symbol.ATOM, "object");
512        }
513
514        @Override
515        public LispObject execute(LispObject arg) {
516            return arg instanceof Cons ? NIL : T;
517        }
518    };
519
520    // ### constantp
521    private static final Primitive CONSTANTP = new pf_constantp();
522    private static final class pf_constantp extends Primitive {
523        pf_constantp() {
524            super(Symbol.CONSTANTP, "form &optional environment");
525        }
526
527        @Override
528        public LispObject execute(LispObject arg) {
529            return arg.constantp() ? T : NIL;
530        }
531        @Override
532        public LispObject execute(LispObject first, LispObject second)
533
534        {
535            return first.constantp() ? T : NIL;
536        }
537    };
538
539    // ### functionp
540    private static final Primitive FUNCTIONP = new pf_functionp();
541    private static final class pf_functionp extends Primitive {
542        pf_functionp() {
543            super(Symbol.FUNCTIONP, "object");
544        }
545
546        @Override
547        public LispObject execute(LispObject arg) {
548            return (arg instanceof Function || arg instanceof FuncallableStandardObject) ? T : NIL;
549        }
550    };
551
552    // ### special-operator-p
553    private static final Primitive SPECIAL_OPERATOR_P = new pf_special_operator_p();
554    private static final class pf_special_operator_p extends Primitive {
555        pf_special_operator_p() {
556            super(Symbol.SPECIAL_OPERATOR_P, "symbol");
557        }
558
559        @Override
560        public LispObject execute(LispObject arg) {
561            return arg.isSpecialOperator() ? T : NIL;
562        }
563    };
564
565    // ### symbolp
566    private static final Primitive SYMBOLP = new pf_symbolp();
567    private static final class pf_symbolp extends Primitive {
568        pf_symbolp() {
569            super(Symbol.SYMBOLP, "object");
570        }
571
572        @Override
573        public LispObject execute(LispObject arg) {
574            return arg instanceof Symbol ? T : NIL;
575        }
576    };
577
578    // ### endp
579    private static final Primitive ENDP = new pf_endp();
580    private static final class pf_endp extends Primitive {
581        pf_endp() {
582            super(Symbol.ENDP, "list");
583        }
584
585        @Override
586        public LispObject execute(LispObject arg) {
587            return arg.endp() ? T : NIL;
588        }
589    };
590
591    // ### null
592    private static final Primitive NULL = new pf_null();
593    private static final class pf_null extends Primitive {
594        pf_null() {
595            super(Symbol.NULL, "object");
596        }
597
598        @Override
599        public LispObject execute(LispObject arg) {
600            return arg == NIL ? T : NIL;
601        }
602    };
603
604    // ### not
605    private static final Primitive NOT = new pf_not();
606    private static final class pf_not extends Primitive {
607        pf_not() {
608            super(Symbol.NOT, "x");
609        }
610
611        @Override
612        public LispObject execute(LispObject arg) {
613            return arg == NIL ? T : NIL;
614        }
615    };
616
617    // ### plusp
618    private static final Primitive PLUSP = new pf_plusp();
619    private static final class pf_plusp extends Primitive {
620        pf_plusp() {
621            super(Symbol.PLUSP, "real");
622        }
623
624        @Override
625        public LispObject execute(LispObject arg) {
626            return arg.PLUSP();
627        }
628    };
629
630    // ### minusp
631    private static final Primitive MINUSP = new pf_minusp();
632    private static final class pf_minusp extends Primitive {
633        pf_minusp() {
634            super(Symbol.MINUSP, "real");
635        }
636
637        @Override
638        public LispObject execute(LispObject arg) {
639            return arg.MINUSP();
640        }
641    };
642
643    // ### zerop
644    private static final Primitive ZEROP = new pf_zerop();
645    private static final class pf_zerop extends Primitive {
646        pf_zerop() {
647            super(Symbol.ZEROP, "number");
648        }
649
650        @Override
651        public LispObject execute(LispObject arg) {
652            return arg.ZEROP();
653        }
654    };
655
656    // ### fixnump
657    private static final Primitive FIXNUMP = new pf_fixnump();
658    private static final class pf_fixnump extends Primitive {
659        pf_fixnump() {
660            super("fixnump", PACKAGE_EXT, true);
661        }
662
663        @Override
664        public LispObject execute(LispObject arg) {
665            return arg instanceof Fixnum ? T : NIL;
666        }
667    };
668
669    // ### symbol-value
670    private static final Primitive SYMBOL_VALUE = new pf_symbol_value();
671    private static final class pf_symbol_value extends Primitive {
672        pf_symbol_value() {
673            super(Symbol.SYMBOL_VALUE, "symbol");
674        }
675
676        @Override
677        public LispObject execute(LispObject arg) {
678            final LispObject value;
679            value = checkSymbol(arg).symbolValue();
680            return value;
681        }
682    };
683
684    // ### set symbol value => value
685    private static final Primitive SET = new pf_set();
686    private static final class pf_set extends Primitive {
687        pf_set() {
688            super(Symbol.SET, "symbol value");
689        }
690
691        @Override
692        public LispObject execute(LispObject first, LispObject second)
693
694        {
695            return LispThread.currentThread().setSpecialVariable(checkSymbol(first),
696                    second);
697        }
698    };
699
700    // ### rplaca
701    private static final Primitive RPLACA = new pf_rplaca();
702    private static final class pf_rplaca extends Primitive {
703        pf_rplaca() {
704            super(Symbol.RPLACA, "cons object");
705        }
706
707        @Override
708        public LispObject execute(LispObject first, LispObject second)
709
710        {
711            first.setCar(second);
712            return first;
713        }
714    };
715
716    // ### rplacd
717    private static final Primitive RPLACD = new pf_rplacd();
718    private static final class pf_rplacd extends Primitive {
719        pf_rplacd() {
720            super(Symbol.RPLACD, "cons object");
721        }
722
723        @Override
724        public LispObject execute(LispObject first, LispObject second)
725
726        {
727            first.setCdr(second);
728            return first;
729        }
730    };
731
732    // ### +
733    private static final Primitive ADD = new pf_add();
734    private static final class pf_add extends Primitive {
735        pf_add() {
736            super(Symbol.PLUS, "&rest numbers");
737        }
738
739        @Override
740        public LispObject execute() {
741            return Fixnum.ZERO;
742        }
743        @Override
744        public LispObject execute(LispObject arg) {
745            if (arg.numberp())
746                return arg;
747            return type_error(arg, Symbol.NUMBER);
748        }
749        @Override
750        public LispObject execute(LispObject first, LispObject second)
751
752        {
753            return first.add(second);
754        }
755        @Override
756        public LispObject execute(LispObject first, LispObject second,
757                                  LispObject third)
758
759        {
760            return first.add(second).add(third);
761        }
762        @Override
763        public LispObject execute(LispObject[] args) {
764            LispObject result = Fixnum.ZERO;
765            final int length = args.length;
766            for (int i = 0; i < length; i++)
767                result = result.add(args[i]);
768            return result;
769        }
770    };
771
772    // ### 1+
773    private static final Primitive ONE_PLUS = new pf_one_plus();
774    private static final class pf_one_plus extends Primitive {
775        pf_one_plus() {
776            super(Symbol.ONE_PLUS, "number");
777        }
778
779        @Override
780        public LispObject execute(LispObject arg) {
781            return arg.incr();
782        }
783    };
784
785    // ### -
786    private static final Primitive SUBTRACT = new pf_subtract();
787    private static final class pf_subtract extends Primitive {
788        pf_subtract() {
789            super(Symbol.MINUS, "minuend &rest subtrahends");
790        }
791
792        @Override
793        public LispObject execute() {
794            return error(new WrongNumberOfArgumentsException(this, 1, -1));
795        }
796        @Override
797        public LispObject execute(LispObject arg) {
798            return arg.negate();
799        }
800        @Override
801        public LispObject execute(LispObject first, LispObject second)
802
803        {
804            return first.subtract(second);
805        }
806        @Override
807        public LispObject execute(LispObject[] args) {
808            LispObject result = args[0];
809            for (int i = 1; i < args.length; i++)
810                result = result.subtract(args[i]);
811            return result;
812        }
813    };
814
815    // ### 1-
816    private static final Primitive ONE_MINUS = new pf_one_minus();
817    private static final class pf_one_minus extends Primitive {
818        pf_one_minus() {
819            super(Symbol.ONE_MINUS, "number");
820        }
821
822        @Override
823        public LispObject execute(LispObject arg) {
824            return arg.decr();
825        }
826    };
827
828    // ### when
829    private static final SpecialOperator WHEN = new sf_when();
830    private static final class sf_when extends SpecialOperator {
831        sf_when() {
832            super(Symbol.WHEN);
833        }
834
835        @Override
836        public LispObject execute(LispObject args, Environment env)
837
838        {
839            if (args == NIL)
840                return error(new WrongNumberOfArgumentsException(this, 1, -1));
841            final LispThread thread = LispThread.currentThread();
842            if (eval(args.car(), env, thread) != NIL) {
843                args = args.cdr();
844                thread.clearValues();
845                return progn(args, env, thread);
846            }
847            return thread.setValues(NIL);
848        }
849    };
850
851    // ### unless
852    private static final SpecialOperator UNLESS = new sf_unless();
853    private static final class sf_unless extends SpecialOperator {
854        sf_unless() {
855            super(Symbol.UNLESS);
856        }
857
858        @Override
859        public LispObject execute(LispObject args, Environment env)
860
861        {
862            if (args == NIL)
863                return error(new WrongNumberOfArgumentsException(this, 1, -1));
864            final LispThread thread = LispThread.currentThread();
865            if (eval(args.car(), env, thread) == NIL) {
866                args = args.cdr();
867                thread.clearValues();
868                return progn(args, env, thread);
869            }
870            return thread.setValues(NIL);
871        }
872    };
873
874    // ### %stream-output-object object stream => object
875    private static final Primitive _STREAM_OUTPUT_OBJECT = new pf__stream_output_object();
876    private static final class pf__stream_output_object extends Primitive {
877        pf__stream_output_object() {
878            super("%stream-output-object", PACKAGE_SYS, true);
879        }
880
881        @Override
882        public LispObject execute(LispObject first, LispObject second)
883
884        {
885            checkStream(second)._writeString(first.printObject());
886            return first;
887        }
888    };
889
890    // ### %output-object object stream => object
891    private static final Primitive _OUTPUT_OBJECT = new pf__output_object();
892    private static final class pf__output_object extends Primitive {
893        pf__output_object() {
894            super("%output-object", PACKAGE_SYS, true);
895        }
896
897        @Override
898        public LispObject execute(LispObject first, LispObject second)
899
900        {
901            final LispObject out;
902            if (second == T)
903                out = Symbol.TERMINAL_IO.symbolValue();
904            else if (second == NIL)
905                out = Symbol.STANDARD_OUTPUT.symbolValue();
906            else
907                out = second;
908            String output = first.printObject();
909            checkStream(out)._writeString(output);
910            return first;
911        }
912    };
913
914    // ### %write-to-string object => string
915    private static final Primitive _WRITE_TO_STRING = new pf__write_to_string();
916    private static final class pf__write_to_string extends Primitive {
917        pf__write_to_string() {
918            super("%write-to-string", PACKAGE_SYS, false);
919        }
920
921        @Override
922        public LispObject execute(LispObject arg) {
923            return new SimpleString(arg.printObject());
924        }
925    };
926
927    // ### %stream-terpri output-stream => nil
928    private static final Primitive _STREAM_TERPRI = new pf__stream_terpri();
929    private static final class pf__stream_terpri extends Primitive {
930        pf__stream_terpri() {
931            super("%stream-terpri", PACKAGE_SYS, true, "output-stream");
932        }
933
934        @Override
935        public LispObject execute(LispObject arg) {
936            checkStream(arg)._writeChar('\n');
937            return NIL;
938        }
939    };
940
941    // ### %terpri output-stream => nil
942    private static final Primitive _TERPRI = new pf__terpri();
943    private static final class pf__terpri extends Primitive {
944        pf__terpri() {
945            super("%terpri", PACKAGE_SYS, false, "output-stream");
946        }
947
948        @Override
949        public LispObject execute(LispObject arg) {
950            if (arg == T)
951                arg = Symbol.TERMINAL_IO.symbolValue();
952            else if (arg == NIL)
953                arg = Symbol.STANDARD_OUTPUT.symbolValue();
954            final Stream stream;
955            stream = checkStream(arg);
956            return stream.terpri();
957        }
958    };
959
960    // ### %fresh-line
961    // %fresh-line &optional output-stream => generalized-boolean
962    private static final Primitive _FRESH_LINE = new pf__fresh_line();
963    private static final class pf__fresh_line extends Primitive {
964        pf__fresh_line() {
965            super("%fresh-line", PACKAGE_SYS, false, "output-stream");
966        }
967
968        @Override
969        public LispObject execute(LispObject arg) {
970            if (arg == T)
971                arg = Symbol.TERMINAL_IO.symbolValue();
972            else if (arg == NIL)
973                arg = Symbol.STANDARD_OUTPUT.symbolValue();
974            final Stream stream;
975            stream = checkStream(arg);
976            return stream.freshLine();
977        }
978    };
979
980    // ### boundp
981    // Determines only whether a symbol has a value in the global environment;
982    // any lexical bindings are ignored.
983    private static final Primitive BOUNDP = new pf_boundp();
984    private static final class pf_boundp extends Primitive {
985        pf_boundp() {
986            super(Symbol.BOUNDP, "symbol");
987        }
988
989        @Override
990        public LispObject execute(LispObject arg) {
991            final Symbol symbol;
992            symbol = checkSymbol(arg);
993            // PROGV: "If too few values are supplied, the remaining symbols
994            // are bound and then made to have no value." So BOUNDP must
995            // explicitly check for a binding with no value.
996            SpecialBinding binding =
997                LispThread.currentThread().getSpecialBinding(symbol);
998            if (binding != null)
999                return binding.value != null ? T : NIL;
1000            // No binding.
1001            return symbol.getSymbolValue() != null ? T : NIL;
1002        }
1003    };
1004
1005    // ### fboundp
1006    private static final Primitive FBOUNDP = new pf_fboundp();
1007    private static final class pf_fboundp extends Primitive {
1008        pf_fboundp() {
1009            super(Symbol.FBOUNDP, "name");
1010        }
1011
1012        @Override
1013        public LispObject execute(LispObject arg) {
1014            if (arg instanceof Symbol)
1015                return arg.getSymbolFunction() != null ? T : NIL;
1016            if (isValidSetfFunctionName(arg)) {
1017                LispObject f = get(arg.cadr(), Symbol.SETF_FUNCTION, null);
1018                return f != null ? T : NIL;
1019            }
1020            return type_error(arg, FUNCTION_NAME);
1021        }
1022    };
1023
1024    // ### fmakunbound name => name
1025    private static final Primitive FMAKUNBOUND = new pf_fmakunbound();
1026    private static final class pf_fmakunbound extends Primitive {
1027        pf_fmakunbound() {
1028            super(Symbol.FMAKUNBOUND, "name");
1029        }
1030
1031        @Override
1032        public LispObject execute(LispObject arg) {
1033            if (arg instanceof Symbol) {
1034                checkSymbol(arg).setSymbolFunction(null);
1035                return arg;
1036            }
1037            if (isValidSetfFunctionName(arg)) {
1038                remprop((Symbol)arg.cadr(), Symbol.SETF_FUNCTION);
1039                return arg;
1040            }
1041            return type_error(arg, FUNCTION_NAME);
1042        }
1043    };
1044
1045    // ### setf-function-name-p
1046    private static final Primitive SETF_FUNCTION_NAME_P = new pf_setf_function_name_p();
1047    private static final class pf_setf_function_name_p extends Primitive {
1048        pf_setf_function_name_p() {
1049            super("setf-function-name-p", PACKAGE_SYS, true, "thing");
1050        }
1051
1052        @Override
1053        public LispObject execute(LispObject arg) {
1054            return isValidSetfFunctionName(arg) ? T : NIL;
1055        }
1056    };
1057
1058    // ### remprop
1059    private static final Primitive REMPROP = new pf_remprop();
1060    private static final class pf_remprop extends Primitive {
1061        pf_remprop() {
1062            super(Symbol.REMPROP, "symbol indicator");
1063        }
1064
1065        @Override
1066        public LispObject execute(LispObject first, LispObject second)
1067
1068        {
1069            return remprop(checkSymbol(first), second);
1070        }
1071    };
1072
1073    // ### append
1074    public static final Primitive APPEND = new pf_append();
1075    private static final class pf_append extends Primitive {
1076        pf_append() {
1077            super(Symbol.APPEND, "&rest lists");
1078        }
1079
1080        @Override
1081        public LispObject execute() {
1082            return NIL;
1083        }
1084        @Override
1085        public LispObject execute(LispObject arg) {
1086            return arg;
1087        }
1088        @Override
1089        public LispObject execute(LispObject first, LispObject second)
1090
1091        {
1092            if (first == NIL)
1093                return second;
1094            // APPEND is required to copy its first argument.
1095            Cons result = new Cons(first.car());
1096            Cons splice = result;
1097            first = first.cdr();
1098            while (first != NIL) {
1099                Cons temp = new Cons(first.car());
1100                splice.cdr = temp;
1101                splice = temp;
1102                first = first.cdr();
1103            }
1104            splice.cdr = second;
1105            return result;
1106        }
1107        @Override
1108        public LispObject execute(LispObject first, LispObject second,
1109                                  LispObject third)
1110
1111        {
1112            if (first == NIL)
1113                return execute(second, third);
1114            Cons result = new Cons(first.car());
1115            Cons splice = result;
1116            first = first.cdr();
1117            while (first != NIL) {
1118                Cons temp = new Cons(first.car());
1119                splice.cdr = temp;
1120                splice = temp;
1121                first = first.cdr();
1122            }
1123            while (second != NIL) {
1124                Cons temp = new Cons(second.car());
1125                splice.cdr = temp;
1126                splice = temp;
1127                second = second.cdr();
1128            }
1129            splice.cdr = third;
1130            return result;
1131        }
1132        @Override
1133        public LispObject execute(LispObject[] args) {
1134            Cons result = null;
1135            Cons splice = null;
1136            final int limit = args.length - 1;
1137            int i;
1138            for (i = 0; i < limit; i++) {
1139                LispObject top = args[i];
1140                if (top == NIL)
1141                    continue;
1142                result = new Cons(top.car());
1143                splice = result;
1144                top = top.cdr();
1145                while (top != NIL) {
1146                    Cons temp = new Cons(top.car());
1147                    splice.cdr = temp;
1148                    splice = temp;
1149                    top = top.cdr();
1150                }
1151                break;
1152            }
1153            if (result == null)
1154                return args[i];
1155            for (++i; i < limit; i++) {
1156                LispObject top = args[i];
1157                while (top != NIL) {
1158                    Cons temp = new Cons(top.car());
1159                    splice.cdr = temp;
1160                    splice = temp;
1161                    top = top.cdr();
1162                }
1163            }
1164            splice.cdr = args[i];
1165            return result;
1166        }
1167    };
1168
1169    // ### nconc
1170    private static final Primitive NCONC = new pf_nconc();
1171    private static final class pf_nconc extends Primitive {
1172        pf_nconc() {
1173            super(Symbol.NCONC, "&rest lists");
1174        }
1175
1176        @Override
1177        public LispObject execute() {
1178            return NIL;
1179        }
1180        @Override
1181        public LispObject execute(LispObject arg) {
1182            return arg;
1183        }
1184        @Override
1185        public LispObject execute(LispObject first, LispObject second)
1186
1187        {
1188            if (first == NIL)
1189                return second;
1190            if (first instanceof Cons) {
1191                LispObject result = first;
1192                Cons splice = null;
1193                while (first instanceof Cons) {
1194                    splice = (Cons) first;
1195                    first = splice.cdr;
1196                }
1197                splice.cdr = second;
1198                return result;
1199            }
1200            return type_error(first, Symbol.LIST);
1201        }
1202        @Override
1203        public LispObject execute(LispObject[] array) {
1204            LispObject result = null;
1205            Cons splice = null;
1206            final int limit = array.length - 1;
1207            int i;
1208            for (i = 0; i < limit; i++) {
1209                LispObject list = array[i];
1210                if (list == NIL)
1211                    continue;
1212                if (list instanceof Cons) {
1213                    if (splice != null) {
1214                        splice.cdr = list;
1215                        splice = (Cons) list;
1216                    }
1217                    while (list instanceof Cons) {
1218                        if (result == null) {
1219                            result = list;
1220                            splice = (Cons) result;
1221                        } else
1222                            splice = (Cons) list;
1223                        list = splice.cdr;
1224                    }
1225                } else
1226                    type_error(list, Symbol.LIST);
1227            }
1228            if (result == null)
1229                return array[i];
1230            splice.cdr = array[i];
1231            return result;
1232        }
1233    };
1234
1235    // ### =
1236    // Numeric equality.
1237    private static final Primitive EQUALS = new pf_equals();
1238    private static final class pf_equals extends Primitive {
1239        pf_equals() {
1240            super(Symbol.EQUALS, "&rest numbers");
1241        }
1242
1243        @Override
1244        public LispObject execute() {
1245            return error(new WrongNumberOfArgumentsException(this, 1, -1));
1246        }
1247        @Override
1248        public LispObject execute(LispObject arg) {
1249            return T;
1250        }
1251        @Override
1252        public LispObject execute(LispObject first, LispObject second)
1253
1254        {
1255            return first.isEqualTo(second) ? T : NIL;
1256        }
1257        @Override
1258        public LispObject execute(LispObject first, LispObject second,
1259                                  LispObject third)
1260
1261        {
1262            if (first.isEqualTo(second) && second.isEqualTo(third))
1263                return T;
1264            else
1265                return NIL;
1266        }
1267        @Override
1268        public LispObject execute(LispObject[] array) {
1269            final int length = array.length;
1270            final LispObject obj = array[0];
1271            for (int i = 1; i < length; i++) {
1272                if (array[i].isNotEqualTo(obj))
1273                    return NIL;
1274            }
1275            return T;
1276        }
1277    };
1278
1279    // ### /=
1280    // Returns true if no two numbers are the same; otherwise returns false.
1281    private static final Primitive NOT_EQUALS = new pf_not_equals();
1282    private static final class pf_not_equals extends Primitive {
1283        pf_not_equals() {
1284            super(Symbol.NOT_EQUALS, "&rest numbers");
1285        }
1286
1287        @Override
1288        public LispObject execute() {
1289            return error(new WrongNumberOfArgumentsException(this, 1, -1));
1290        }
1291        @Override
1292        public LispObject execute(LispObject arg) {
1293            return T;
1294        }
1295        @Override
1296        public LispObject execute(LispObject first, LispObject second)
1297
1298        {
1299            return first.isNotEqualTo(second) ? T : NIL;
1300        }
1301        @Override
1302        public LispObject execute(LispObject first, LispObject second,
1303                                  LispObject third)
1304
1305        {
1306            if (first.isEqualTo(second))
1307                return NIL;
1308            if (first.isEqualTo(third))
1309                return NIL;
1310            if (second.isEqualTo(third))
1311                return NIL;
1312            return T;
1313        }
1314        @Override
1315        public LispObject execute(LispObject[] array) {
1316            final int length = array.length;
1317            for (int i = 0; i < length; i++) {
1318                final LispObject obj = array[i];
1319                for (int j = i+1; j < length; j++) {
1320                    if (array[j].isEqualTo(obj))
1321                        return NIL;
1322                }
1323            }
1324            return T;
1325        }
1326    };
1327
1328    // ### <
1329    // Numeric comparison.
1330    private static final Primitive LT = new pf_lt();
1331    private static final class pf_lt extends Primitive {
1332        pf_lt() {
1333            super(Symbol.LT, "&rest numbers");
1334        }
1335
1336        @Override
1337        public LispObject execute() {
1338            return error(new WrongNumberOfArgumentsException(this, 1, -1));
1339        }
1340        @Override
1341        public LispObject execute(LispObject arg) {
1342            return T;
1343        }
1344        @Override
1345        public LispObject execute(LispObject first, LispObject second)
1346
1347        {
1348            return first.isLessThan(second) ? T : NIL;
1349        }
1350        @Override
1351        public LispObject execute(LispObject first, LispObject second,
1352                                  LispObject third)
1353
1354        {
1355            if (first.isLessThan(second) && second.isLessThan(third))
1356                return T;
1357            else
1358                return NIL;
1359        }
1360        @Override
1361        public LispObject execute(LispObject[] array) {
1362            final int length = array.length;
1363            for (int i = 1; i < length; i++) {
1364                if (array[i].isLessThanOrEqualTo(array[i-1]))
1365                    return NIL;
1366            }
1367            return T;
1368        }
1369    };
1370
1371    // ### <=
1372    private static final Primitive LE = new pf_le();
1373    private static final class pf_le extends Primitive {
1374        pf_le() {
1375            super(Symbol.LE, "&rest numbers");
1376        }
1377
1378        @Override
1379        public LispObject execute() {
1380            return error(new WrongNumberOfArgumentsException(this, 1, -1));
1381        }
1382        @Override
1383        public LispObject execute(LispObject arg) {
1384            return T;
1385        }
1386        @Override
1387        public LispObject execute(LispObject first, LispObject second)
1388
1389        {
1390            return first.isLessThanOrEqualTo(second) ? T : NIL;
1391        }
1392        @Override
1393        public LispObject execute(LispObject first, LispObject second,
1394                                  LispObject third)
1395
1396        {
1397            if (first.isLessThanOrEqualTo(second) && second.isLessThanOrEqualTo(third))
1398                return T;
1399            else
1400                return NIL;
1401        }
1402        @Override
1403        public LispObject execute(LispObject[] array) {
1404            final int length = array.length;
1405            for (int i = 1; i < length; i++) {
1406                if (array[i].isLessThan(array[i-1]))
1407                    return NIL;
1408            }
1409            return T;
1410        }
1411    };
1412
1413    // ### >
1414    private static final Primitive GT = new pf_gt();
1415    private static final class pf_gt extends Primitive {
1416        pf_gt() {
1417            super(Symbol.GT, "&rest numbers");
1418        }
1419
1420        @Override
1421        public LispObject execute() {
1422            return error(new WrongNumberOfArgumentsException(this, 1, -1));
1423        }
1424        @Override
1425        public LispObject execute(LispObject arg) {
1426            return T;
1427        }
1428        @Override
1429        public LispObject execute(LispObject first, LispObject second)
1430
1431        {
1432            return first.isGreaterThan(second) ? T : NIL;
1433        }
1434        @Override
1435        public LispObject execute(LispObject first, LispObject second,
1436                                  LispObject third)
1437
1438        {
1439            if (first.isGreaterThan(second) && second.isGreaterThan(third))
1440                return T;
1441            else
1442                return NIL;
1443        }
1444        @Override
1445        public LispObject execute(LispObject[] array) {
1446            final int length = array.length;
1447            for (int i = 1; i < length; i++) {
1448                if (array[i].isGreaterThanOrEqualTo(array[i-1]))
1449                    return NIL;
1450            }
1451            return T;
1452        }
1453    };
1454
1455    // ### >=
1456    private static final Primitive GE = new pf_ge();
1457    private static final class pf_ge extends Primitive {
1458        pf_ge() {
1459            super(Symbol.GE, "&rest numbers");
1460        }
1461
1462        @Override
1463        public LispObject execute() {
1464            return error(new WrongNumberOfArgumentsException(this, 1, -1));
1465        }
1466        @Override
1467        public LispObject execute(LispObject arg) {
1468            return T;
1469        }
1470        @Override
1471        public LispObject execute(LispObject first, LispObject second)
1472
1473        {
1474            return first.isGreaterThanOrEqualTo(second) ? T : NIL;
1475        }
1476        @Override
1477        public LispObject execute(LispObject first, LispObject second,
1478                                  LispObject third)
1479
1480        {
1481            if (first.isGreaterThanOrEqualTo(second) && second.isGreaterThanOrEqualTo(third))
1482                return T;
1483            else
1484                return NIL;
1485        }
1486        @Override
1487        public LispObject execute(LispObject[] array) {
1488            final int length = array.length;
1489            for (int i = 1; i < length; i++) {
1490                if (array[i].isGreaterThan(array[i-1]))
1491                    return NIL;
1492            }
1493            return T;
1494        }
1495    };
1496
1497    // ### nth n list => object
1498    private static final Primitive NTH = new pf_nth();
1499    private static final class pf_nth extends Primitive {
1500        pf_nth() {
1501            super(Symbol.NTH, "n list");
1502        }
1503
1504        @Override
1505        public LispObject execute(LispObject first, LispObject second)
1506
1507        {
1508            return second.NTH(first);
1509        }
1510    };
1511
1512    // ### %set-nth n list new-object => new-object
1513    private static final Primitive _SET_NTH = new pf__set_nth();
1514    private static final class pf__set_nth extends Primitive {
1515        pf__set_nth() {
1516            super("%set-nth", PACKAGE_SYS, false);
1517        }
1518
1519        @Override
1520        public LispObject execute(LispObject first, LispObject second,
1521                                  LispObject third)
1522
1523        {
1524            int index = Fixnum.getValue(first);
1525            if (index < 0)
1526                error(new TypeError("(SETF NTH): invalid index " + index + "."));
1527            int i = 0;
1528            while (true) {
1529                if (i == index) {
1530                    second.setCar(third);
1531                    return third;
1532                }
1533                second = second.cdr();
1534                if (second == NIL) {
1535                    return error(new LispError("(SETF NTH): the index " +
1536                                               index + "is too large."));
1537                }
1538                ++i;
1539            }
1540        }
1541    };
1542
1543    // ### nthcdr
1544    private static final Primitive NTHCDR = new pf_nthcdr();
1545    private static final class pf_nthcdr extends Primitive {
1546        pf_nthcdr() {
1547            super(Symbol.NTHCDR, "n list");
1548        }
1549
1550        @Override
1551        public LispObject execute(LispObject first, LispObject second)
1552
1553        {
1554            final int index = Fixnum.getValue(first);
1555            if (index < 0)
1556                return type_error(first,
1557                                  list(Symbol.INTEGER, Fixnum.ZERO));
1558            for (int i = 0; i < index; i++) {
1559                second = second.cdr();
1560                if (second == NIL)
1561                    return NIL;
1562            }
1563            return second;
1564        }
1565    };
1566
1567    /** Stub to be replaced later when signal.lisp has been loaded. */
1568    // ### error
1569    private static final Primitive ERROR = new pf_error();
1570    private static final class pf_error extends Primitive {
1571        pf_error() {
1572            super(Symbol.ERROR, "datum &rest arguments");
1573        }
1574
1575        @Override
1576        @SuppressWarnings("CallToThreadDumpStack")
1577        public LispObject execute(LispObject[] args) {
1578            Error e = new IntegrityError();
1579
1580            e.printStackTrace();
1581
1582            System.out.println("ERROR placeholder called with arguments:");
1583
1584            if (args.length == 1 && args[0] instanceof Condition) {
1585                System.out.println(args[0].princToString());
1586                System.out.println(((Condition)args[0]).getConditionReport());
1587            } else
1588            for (LispObject a : args)
1589                System.out.println(a.princToString());
1590
1591            throw e;
1592        }
1593    };
1594
1595    /** Stub replaced when compiler-pass2.lisp has been loaded */
1596    // ### autocompile
1597    private static final Primitive AUTOCOMPILE = new pf_autocompile();
1598    private static final class pf_autocompile extends Primitive {
1599        pf_autocompile() {
1600            super(Symbol.AUTOCOMPILE, "function");
1601        }
1602
1603        @Override
1604        public LispObject execute(LispObject function) {
1605            return NIL;
1606        }
1607    };
1608
1609    // ### signal
1610    /** Placeholder function, to be replaced by the function
1611     * defined in signal.lisp
1612     *
1613     * Calling this function is an error: we're not set up for
1614     * signalling yet.
1615     */
1616    private static final Primitive SIGNAL = new pf_signal();
1617    private static final class pf_signal extends Primitive {
1618        pf_signal() {
1619            super(Symbol.SIGNAL, "datum &rest arguments");
1620        }
1621
1622        @Override
1623        public LispObject execute(LispObject[] args) {
1624            if (args.length < 1)
1625                return error(new WrongNumberOfArgumentsException(this, 1, -1));
1626            if (args[0] instanceof Condition)
1627                return error((Condition)args[0]);
1628            return error(new SimpleCondition());
1629        }
1630    };
1631
1632    // ### undefined-function-called
1633    // Redefined in restart.lisp.
1634    private static final Primitive UNDEFINED_FUNCTION_CALLED = new pf_undefined_function_called();
1635    private static final class pf_undefined_function_called extends Primitive {
1636        pf_undefined_function_called() {
1637            super(Symbol.UNDEFINED_FUNCTION_CALLED, "name arguments");
1638        }
1639
1640        @Override
1641        public LispObject execute(LispObject first, LispObject second)
1642
1643        {
1644            return error(new UndefinedFunction(first));
1645        }
1646    };
1647
1648    // ### %format
1649    private static final Primitive _FORMAT = new pf__format();
1650    private static final class pf__format extends Primitive {
1651        pf__format() {
1652            super("%format", PACKAGE_SYS, false,
1653                  "destination control-string &rest args");
1654        }
1655
1656        @Override
1657        public LispObject execute(LispObject first, LispObject second,
1658                                  LispObject third)
1659
1660        {
1661            LispObject destination = first;
1662            // Copy remaining arguments.
1663            LispObject[] _args = new LispObject[2];
1664            _args[0] = second;
1665            _args[1] = third;
1666            String s = _format(_args);
1667            return outputFormattedString(s, destination);
1668        }
1669        @Override
1670        public LispObject execute(LispObject first, LispObject second,
1671                                  LispObject third, LispObject fourth)
1672
1673        {
1674            LispObject destination = first;
1675            // Copy remaining arguments.
1676            LispObject[] _args = new LispObject[3];
1677            _args[0] = second;
1678            _args[1] = third;
1679            _args[2] = fourth;
1680            String s = _format(_args);
1681            return outputFormattedString(s, destination);
1682        }
1683        @Override
1684        public LispObject execute(LispObject[] args) {
1685            if (args.length < 2)
1686                return error(new WrongNumberOfArgumentsException(this, 2, -1));
1687            LispObject destination = args[0];
1688            // Copy remaining arguments.
1689            LispObject[] _args = new LispObject[args.length - 1];
1690            for (int i = 0; i < _args.length; i++)
1691                _args[i] = args[i+1];
1692            String s = _format(_args);
1693            return outputFormattedString(s, destination);
1694        }
1695        private final String _format(LispObject[] args)
1696
1697        {
1698            LispObject formatControl = args[0];
1699            LispObject formatArguments = NIL;
1700            for (int i = 1; i < args.length; i++)
1701                formatArguments = new Cons(args[i], formatArguments);
1702            formatArguments = formatArguments.nreverse();
1703            return format(formatControl, formatArguments);
1704        }
1705        private final LispObject outputFormattedString(String s,
1706                LispObject destination)
1707
1708        {
1709            if (destination == T) {
1710                checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue())._writeString(s);
1711                return NIL;
1712            }
1713            if (destination == NIL)
1714                return new SimpleString(s);
1715            if (destination instanceof TwoWayStream) {
1716                Stream out = ((TwoWayStream)destination).getOutputStream();
1717                if (out instanceof Stream) {
1718                    (out)._writeString(s);
1719                    return NIL;
1720                }
1721                error(new TypeError("The value " +
1722                                    destination.princToString() +
1723                                    " is not a character output stream."));
1724            }
1725            if (destination instanceof Stream) {
1726                ((Stream)destination)._writeString(s);
1727                return NIL;
1728            }
1729            return NIL;
1730        }
1731    };
1732
1733    static void checkRedefinition(LispObject arg)
1734    {
1735        final LispThread thread = LispThread.currentThread();
1736        if (_WARN_ON_REDEFINITION_.symbolValue(thread) != NIL) {
1737            if (arg instanceof Symbol) {
1738                LispObject oldDefinition = arg.getSymbolFunction();
1739                if (oldDefinition != null
1740                        && !(oldDefinition instanceof Autoload)) {
1741                    LispObject oldSource =
1742                        Extensions.SOURCE_PATHNAME.execute(arg);
1743                    LispObject currentSource = _SOURCE_.symbolValue(thread);
1744                    if (currentSource == NIL)
1745                        currentSource = Keyword.TOP_LEVEL;
1746                    if (oldSource != NIL) {
1747                        if (currentSource.equal(oldSource))
1748                            return; // OK
1749                    }
1750                    if (currentSource == Keyword.TOP_LEVEL) {
1751                        Symbol.STYLE_WARN.execute(new SimpleString("redefining ~S at top level"),
1752                                                  arg);
1753
1754                    } else {
1755                        SpecialBindingsMark mark = thread.markSpecialBindings();
1756                        thread.bindSpecial(Symbol._PACKAGE_, PACKAGE_CL);
1757                        try {
1758                            Symbol.STYLE_WARN.execute(new SimpleString("redefining ~S in ~S"),
1759                                                      arg, currentSource);
1760                        }
1761                        finally {
1762                            thread.resetSpecialBindings(mark);
1763                        }
1764                    }
1765                }
1766            }
1767        }
1768    }
1769
1770    // ### %defun name definition => name
1771    private static final Primitive _DEFUN = new pf__defun();
1772    private static final class pf__defun extends Primitive {
1773        pf__defun() {
1774            super("%defun", PACKAGE_SYS, true, "name definition");
1775        }
1776
1777        @Override
1778        public LispObject execute(LispObject name, LispObject definition)
1779
1780        {
1781            if (name instanceof Symbol) {
1782                Symbol symbol = (Symbol) name;
1783                if (symbol.getSymbolFunction() instanceof SpecialOperator) {
1784                    return program_error(symbol.getName() + " is a special operator and may not be redefined.");
1785                }
1786            } else if (!isValidSetfFunctionName(name))
1787                return type_error(name, FUNCTION_NAME);
1788            if (definition instanceof Function) {
1789                Symbol.FSET.execute(name, definition, NIL,
1790                                    ((Function)definition).getLambdaList());
1791                return name;
1792            }
1793            return type_error(definition, Symbol.FUNCTION);
1794        }
1795    };
1796
1797    // ### fdefinition-block-name
1798    private static final Primitive FDEFINITION_BLOCK_NAME = new pf_fdefinition_block_name();
1799    private static final class pf_fdefinition_block_name extends Primitive {
1800        pf_fdefinition_block_name() {
1801            super("fdefinition-block-name", PACKAGE_SYS, true, "function-name");
1802        }
1803
1804        @Override
1805        public LispObject execute(LispObject arg) {
1806            if (arg instanceof Symbol)
1807                return arg;
1808            if (isValidSetfFunctionName(arg))
1809                return arg.cadr();
1810            return type_error(arg, FUNCTION_NAME);
1811        }
1812    };
1813
1814    // ### macro-function
1815    private static final Primitive MACRO_FUNCTION = new pf_macro_function();
1816    private static final class pf_macro_function extends Primitive {
1817        pf_macro_function() {
1818            super(Symbol.MACRO_FUNCTION, "symbol &optional environment");
1819        }
1820
1821        @Override
1822        public LispObject execute(LispObject arg) {
1823            LispObject obj = arg.getSymbolFunction();
1824            if (obj instanceof AutoloadMacro) {
1825                ((AutoloadMacro)obj).load();
1826                obj = arg.getSymbolFunction();
1827            }
1828            if (obj instanceof MacroObject)
1829                return ((MacroObject)obj).expander;
1830            if (obj instanceof SpecialOperator) {
1831                obj = get(arg, Symbol.MACROEXPAND_MACRO, NIL);
1832                if (obj instanceof AutoloadMacro) {
1833                    ((AutoloadMacro)obj).load();
1834                    obj = get(arg, Symbol.MACROEXPAND_MACRO, NIL);
1835                }
1836                if (obj instanceof MacroObject)
1837                    return ((MacroObject)obj).expander;
1838            }
1839            return NIL;
1840        }
1841        @Override
1842        public LispObject execute(LispObject first, LispObject second)
1843
1844        {
1845            LispObject obj;
1846            if (second != NIL) {
1847                Environment env = checkEnvironment(second);
1848                obj = env.lookupFunction(first);
1849            } else
1850                obj = first.getSymbolFunction();
1851            if (obj instanceof AutoloadMacro) {
1852                ((AutoloadMacro)obj).load();
1853                obj = first.getSymbolFunction();
1854            }
1855            if (obj instanceof MacroObject)
1856                return ((MacroObject)obj).expander;
1857            if (obj instanceof SpecialOperator) {
1858                obj = get(first, Symbol.MACROEXPAND_MACRO, NIL);
1859                if (obj instanceof AutoloadMacro) {
1860                    ((AutoloadMacro)obj).load();
1861                    obj = get(first, Symbol.MACROEXPAND_MACRO, NIL);
1862                }
1863                if (obj instanceof MacroObject)
1864                    return ((MacroObject)obj).expander;
1865            }
1866            return NIL;
1867        }
1868    };
1869
1870    // ### defmacro
1871    private static final SpecialOperator DEFMACRO = new sf_defmacro();
1872    private static final class sf_defmacro extends SpecialOperator {
1873        sf_defmacro() {
1874            super(Symbol.DEFMACRO);
1875        }
1876
1877        @Override
1878        public LispObject execute(LispObject args, Environment env)
1879
1880        {
1881            Symbol symbol = checkSymbol(args.car());
1882            LispObject expander = MAKE_MACRO_EXPANDER.execute(args);
1883            Closure expansionFunction = new Closure(expander, env);
1884            MacroObject macroObject =
1885                new MacroObject(symbol, expansionFunction);
1886            if (symbol.getSymbolFunction() instanceof SpecialOperator)
1887                put(symbol, Symbol.MACROEXPAND_MACRO, macroObject);
1888            else
1889                symbol.setSymbolFunction(macroObject);
1890            macroObject.setLambdaList(args.cadr());
1891            LispThread.currentThread()._values = null;
1892            return symbol;
1893        }
1894    };
1895
1896    // ### make-macro
1897    private static final Primitive MAKE_MACRO = new pf_make_macro();
1898    private static final class pf_make_macro extends Primitive {
1899        pf_make_macro() {
1900            super("make-macro", PACKAGE_SYS, true, "name expansion-function");
1901        }
1902
1903        @Override
1904        public LispObject execute(LispObject first, LispObject second)
1905
1906        {
1907            return new MacroObject(first, second);
1908        }
1909    };
1910
1911    // ### macro-function-p
1912    private static final Primitive MACRO_FUNCTION_P = new pf_macro_function_p();
1913    private static final class pf_macro_function_p extends Primitive {
1914        pf_macro_function_p() {
1915            super("macro-function-p", PACKAGE_SYS, true, "value");
1916        }
1917
1918        @Override
1919        public LispObject execute(LispObject arg) {
1920            return (arg instanceof MacroObject) ? T : NIL;
1921        }
1922    };
1923
1924
1925    // ### make-symbol-macro
1926    private static final Primitive MAKE_SYMBOL_MACRO = new pf_make_symbol_macro();
1927    private static final class pf_make_symbol_macro extends Primitive {
1928        pf_make_symbol_macro() {
1929            super("make-symbol-macro", PACKAGE_SYS, true, "expansion");
1930        }
1931
1932        @Override
1933        public LispObject execute(LispObject arg) {
1934            return new SymbolMacro(arg);
1935        }
1936    };
1937
1938    // ### %set-symbol-macro
1939    private static final Primitive SET_SYMBOL_MACRO = new pf_set_symbol_macro();
1940    private static final class pf_set_symbol_macro extends Primitive {
1941        pf_set_symbol_macro() {
1942            super("%set-symbol-macro", PACKAGE_SYS, false, "symbol symbol-macro");
1943        }
1944
1945        @Override
1946        public LispObject execute(LispObject sym, LispObject symbolMacro) {
1947            checkSymbol(sym).setSymbolMacro((SymbolMacro) symbolMacro);
1948            return symbolMacro;
1949        }
1950    };
1951
1952    // ### symbol-macro-p
1953    private static final Primitive SYMBOL_MACRO_P = new pf_symbol_macro_p();
1954    private static final class pf_symbol_macro_p extends Primitive {
1955        pf_symbol_macro_p() {
1956            super("symbol-macro-p", PACKAGE_SYS, true, "value");
1957        }
1958
1959        @Override
1960        public LispObject execute(LispObject arg) {
1961            return (arg instanceof SymbolMacro) ? T : NIL;
1962        }
1963    };
1964
1965    // ### %defparameter
1966    private static final Primitive _DEFPARAMETER = new pf__defparameter();
1967    private static final class pf__defparameter extends Primitive {
1968        pf__defparameter() {
1969            super("%defparameter", PACKAGE_SYS, false);
1970        }
1971
1972        @Override
1973        public LispObject execute(LispObject first, LispObject second,
1974                                  LispObject third)
1975
1976        {
1977            final Symbol symbol;
1978            symbol = checkSymbol(first);
1979            if (third instanceof AbstractString)
1980                symbol.setDocumentation(Symbol.VARIABLE, third);
1981            else if (third != NIL)
1982                type_error(third, Symbol.STRING);
1983            symbol.initializeSpecial(second);
1984            return symbol;
1985        }
1986    };
1987
1988    // ### %defvar
1989    private static final Primitive _DEFVAR = new pf__defvar();
1990    private static final class pf__defvar extends Primitive {
1991        pf__defvar() {
1992            super("%defvar", PACKAGE_SYS, false);
1993        }
1994
1995        @Override
1996        public LispObject execute(LispObject arg) {
1997            final Symbol symbol;
1998            symbol = checkSymbol(arg);
1999            symbol.setSpecial(true);
2000            return symbol;
2001        }
2002        @Override
2003        public LispObject execute(LispObject first, LispObject second)
2004
2005        {
2006            final Symbol symbol;
2007            symbol = checkSymbol(first);
2008            symbol.initializeSpecial(second);
2009            return symbol;
2010        }
2011    };
2012
2013    // ### %defconstant name initial-value documentation => name
2014    private static final Primitive _DEFCONSTANT = new pf__defconstant();
2015    private static final class pf__defconstant extends Primitive {
2016        pf__defconstant() {
2017            super("%defconstant", PACKAGE_SYS, false);
2018        }
2019
2020        @Override
2021        public LispObject execute(LispObject first, LispObject second,
2022                                  LispObject third)
2023
2024        {
2025            final Symbol symbol;
2026            symbol = checkSymbol(first);
2027            if (third != NIL) {
2028                if (third instanceof AbstractString)
2029                    symbol.setDocumentation(Symbol.VARIABLE, third);
2030                else
2031                    return type_error(third, Symbol.STRING);
2032            }
2033            symbol.initializeConstant(second);
2034            return symbol;
2035        }
2036    };
2037
2038    // ### cond
2039    private static final SpecialOperator COND = new sf_cond();
2040    private static final class sf_cond extends SpecialOperator {
2041        sf_cond() {
2042            super(Symbol.COND, "&rest clauses");
2043        }
2044
2045        @Override
2046        public LispObject execute(LispObject args, Environment env)
2047        {
2048            final LispThread thread = LispThread.currentThread();
2049            LispObject result = NIL;
2050            while (args != NIL) {
2051                LispObject clause = args.car();
2052                if (! (clause instanceof Cons))
2053                  return error(new ProgramError("COND clause is not a non-empty list: "
2054                                                + clause.princToString()));
2055                result = eval(clause.car(), env, thread);
2056                thread._values = null;
2057                if (result != NIL) {
2058                    LispObject body = clause.cdr();
2059                    while (body != NIL) {
2060                        result = eval(body.car(), env, thread);
2061                        body = ((Cons)body).cdr;
2062                    }
2063                    return result;
2064                }
2065                args = ((Cons)args).cdr;
2066            }
2067            return result;
2068        }
2069    };
2070
2071    // ### case
2072    private static final SpecialOperator CASE = new sf_case();
2073    private static final class sf_case extends SpecialOperator {
2074        sf_case() {
2075            super(Symbol.CASE, "keyform &body cases");
2076        }
2077
2078        @Override
2079        public LispObject execute(LispObject args, Environment env)
2080
2081        {
2082            final LispThread thread = LispThread.currentThread();
2083            LispObject key = eval(args.car(), env, thread);
2084            args = args.cdr();
2085            while (args != NIL) {
2086                LispObject clause = args.car();
2087                LispObject keys = clause.car();
2088                boolean match = false;
2089                if (keys.listp()) {
2090                    while (keys != NIL) {
2091                        LispObject candidate = keys.car();
2092                        if (key.eql(candidate)) {
2093                            match = true;
2094                            break;
2095                        }
2096                        keys = keys.cdr();
2097                    }
2098                } else {
2099                    LispObject candidate = keys;
2100                    if (candidate == T || candidate == Symbol.OTHERWISE)
2101                        match = true;
2102                    else if (key.eql(candidate))
2103                        match = true;
2104                }
2105                if (match) {
2106                    return progn(clause.cdr(), env, thread);
2107                }
2108                args = args.cdr();
2109            }
2110            return NIL;
2111        }
2112    };
2113
2114    // ### ecase
2115    private static final SpecialOperator ECASE = new sf_ecase();
2116    private static final class sf_ecase extends SpecialOperator {
2117        sf_ecase() {
2118            super(Symbol.ECASE, "keyform &body cases");
2119        }
2120
2121        @Override
2122        public LispObject execute(LispObject args, Environment env)
2123
2124        {
2125            final LispThread thread = LispThread.currentThread();
2126            LispObject key = eval(args.car(), env, thread);
2127            LispObject clauses = args.cdr();
2128            while (clauses != NIL) {
2129                LispObject clause = clauses.car();
2130                LispObject keys = clause.car();
2131                boolean match = false;
2132                if (keys.listp()) {
2133                    while (keys != NIL) {
2134                        LispObject candidate = keys.car();
2135                        if (key.eql(candidate)) {
2136                            match = true;
2137                            break;
2138                        }
2139                        keys = keys.cdr();
2140                    }
2141                } else {
2142                    LispObject candidate = keys;
2143                    if (key.eql(candidate))
2144                        match = true;
2145                }
2146                if (match) {
2147                    return progn(clause.cdr(), env, thread);
2148                }
2149                clauses = clauses.cdr();
2150            }
2151            LispObject expectedType = NIL;
2152            clauses = args.cdr();
2153            while (clauses != NIL) {
2154                LispObject clause = clauses.car();
2155                LispObject keys = clause.car();
2156                if (keys.listp()) {
2157                    while (keys != NIL) {
2158                        expectedType = expectedType.push(keys.car());
2159                        keys = keys.cdr();
2160                    }
2161                } else
2162                    expectedType = expectedType.push(keys);
2163                clauses = clauses.cdr();
2164            }
2165            expectedType = expectedType.nreverse();
2166            expectedType = expectedType.push(Symbol.MEMBER);
2167            return type_error(key, expectedType);
2168        }
2169    };
2170
2171    // ### upgraded-array-element-type typespec &optional environment
2172    // => upgraded-typespec
2173    private static final Primitive UPGRADED_ARRAY_ELEMENT_TYPE = new pf_upgraded_array_element_type();
2174    private static final class pf_upgraded_array_element_type extends Primitive {
2175        pf_upgraded_array_element_type() {
2176            super(Symbol.UPGRADED_ARRAY_ELEMENT_TYPE,
2177                  "typespec &optional environment");
2178        }
2179
2180        @Override
2181        public LispObject execute(LispObject arg) {
2182            return getUpgradedArrayElementType(arg);
2183        }
2184        @Override
2185        public LispObject execute(LispObject first, LispObject second)
2186
2187        {
2188            // Ignore environment.
2189            return getUpgradedArrayElementType(first);
2190        }
2191    };
2192
2193    // ### array-rank array => rank
2194    private static final Primitive ARRAY_RANK = new pf_array_rank();
2195    private static final class pf_array_rank extends Primitive {
2196        pf_array_rank() {
2197            super(Symbol.ARRAY_RANK, "array");
2198        }
2199
2200        @Override
2201        public LispObject execute(LispObject arg) {
2202            return Fixnum.getInstance(checkArray(arg).getRank());
2203
2204        }
2205    };
2206
2207    // ### array-dimensions array => dimensions
2208    // Returns a list of integers. Fill pointer (if any) is ignored.
2209    private static final Primitive ARRAY_DIMENSIONS = new pf_array_dimensions();
2210    private static final class pf_array_dimensions extends Primitive {
2211        pf_array_dimensions() {
2212            super(Symbol.ARRAY_DIMENSIONS, "array");
2213        }
2214
2215        @Override
2216        public LispObject execute(LispObject arg) {
2217            return checkArray(arg).getDimensions();
2218        }
2219    };
2220
2221    // ### array-dimension array axis-number => dimension
2222    private static final Primitive ARRAY_DIMENSION = new pf_array_dimension();
2223    private static final class pf_array_dimension extends Primitive {
2224        pf_array_dimension() {
2225            super(Symbol.ARRAY_DIMENSION, "array axis-number");
2226        }
2227
2228        @Override
2229        public LispObject execute(LispObject first, LispObject second)
2230
2231        {
2232            final AbstractArray array = checkArray(first);
2233            return Fixnum.getInstance(array.getDimension(Fixnum.getValue(second)));
2234        }
2235    };
2236
2237    // ### array-total-size array => size
2238    private static final Primitive ARRAY_TOTAL_SIZE = new pf_array_total_size();
2239    private static final class pf_array_total_size extends Primitive {
2240        pf_array_total_size() {
2241            super(Symbol.ARRAY_TOTAL_SIZE, "array");
2242        }
2243
2244        @Override
2245        public LispObject execute(LispObject arg) {
2246            return Fixnum.getInstance(checkArray(arg).getTotalSize());
2247        }
2248    };
2249
2250
2251    // ### array-element-type
2252    // array-element-type array => typespec
2253    private static final Primitive ARRAY_ELEMENT_TYPE = new pf_array_element_type();
2254    private static final class pf_array_element_type extends Primitive {
2255        pf_array_element_type() {
2256            super(Symbol.ARRAY_ELEMENT_TYPE, "array");
2257        }
2258
2259        @Override
2260        public LispObject execute(LispObject arg) {
2261            return checkArray(arg).getElementType();
2262        }
2263    };
2264
2265    // ### adjustable-array-p
2266    private static final Primitive ADJUSTABLE_ARRAY_P = new pf_adjustable_array_p();
2267    private static final class pf_adjustable_array_p extends Primitive {
2268        pf_adjustable_array_p() {
2269            super(Symbol.ADJUSTABLE_ARRAY_P, "array");
2270        }
2271
2272        @Override
2273        public LispObject execute(LispObject arg) {
2274            return checkArray(arg).isAdjustable() ? T : NIL;
2275        }
2276    };
2277
2278    // ### array-displacement array => displaced-to, displaced-index-offset
2279    private static final Primitive ARRAY_DISPLACEMENT = new pf_array_displacement();
2280    private static final class pf_array_displacement extends Primitive {
2281        pf_array_displacement() {
2282            super(Symbol.ARRAY_DISPLACEMENT, "array");
2283        }
2284
2285        @Override
2286        public LispObject execute(LispObject arg) {
2287            return checkArray(arg).arrayDisplacement();
2288
2289        }
2290    };
2291
2292    // ### array-in-bounds-p array &rest subscripts => generalized-boolean
2293    private static final Primitive ARRAY_IN_BOUNDS_P = new pf_array_in_bounds_p();
2294    private static final class pf_array_in_bounds_p extends Primitive {
2295        pf_array_in_bounds_p() {
2296            super(Symbol.ARRAY_IN_BOUNDS_P, "array &rest subscripts");
2297        }
2298
2299        @Override
2300        public LispObject execute(LispObject[] args) {
2301            if (args.length < 1)
2302                return error(new WrongNumberOfArgumentsException(this, 1, -1));
2303            final AbstractArray array;
2304            LispObject r = args[0];
2305            array = checkArray(r);
2306            int rank = array.getRank();
2307            if (rank != args.length - 1) {
2308                StringBuilder sb =
2309                    new StringBuilder("ARRAY-IN-BOUNDS-P: ");
2310                sb.append("wrong number of subscripts (");
2311                sb.append(args.length - 1);
2312                sb.append(") for array of rank ");
2313                sb.append(rank);
2314                sb.append(".");
2315                program_error(sb.toString());
2316            }
2317            for (int i = 0; i < rank; i++) {
2318                LispObject arg = args[i+1];
2319                if (arg instanceof Fixnum) {
2320                    int subscript = ((Fixnum)arg).value;
2321                    if (subscript < 0 || subscript >= array.getDimension(i))
2322                        return NIL;
2323                } else if (arg instanceof Bignum)
2324                    return NIL;
2325                else
2326                    type_error(arg, Symbol.INTEGER);
2327            }
2328            return T;
2329        }
2330    };
2331
2332    // ### %array-row-major-index array subscripts => index
2333    private static final Primitive _ARRAY_ROW_MAJOR_INDEX = new pf__array_row_major_index();
2334    private static final class pf__array_row_major_index extends Primitive {
2335        pf__array_row_major_index() {
2336            super("%array-row-major-index", PACKAGE_SYS, false);
2337        }
2338
2339        @Override
2340        public LispObject execute(LispObject first, LispObject second)
2341
2342        {
2343            final AbstractArray array;
2344            array = checkArray(first);
2345            LispObject[] subscripts = second.copyToArray();
2346            return number(array.getRowMajorIndex(subscripts));
2347        }
2348    };
2349
2350    // ### aref array &rest subscripts => element
2351    private static final Primitive AREF = new pf_aref();
2352    private static final class pf_aref extends Primitive {
2353        pf_aref() {
2354            super(Symbol.AREF, "array &rest subscripts");
2355        }
2356
2357        @Override
2358        public LispObject execute() {
2359            return error(new WrongNumberOfArgumentsException(this, 1, -1));
2360        }
2361        @Override
2362        public LispObject execute(LispObject arg) {
2363            final AbstractArray array;
2364            array = checkArray( arg);
2365            if (array.getRank() == 0)
2366                return array.AREF(0);
2367            StringBuilder sb =
2368                new StringBuilder("Wrong number of subscripts (0) for array of rank ");
2369            sb.append(array.getRank());
2370            sb.append('.');
2371            return program_error(sb.toString());
2372        }
2373        @Override
2374        public LispObject execute(LispObject first, LispObject second)
2375
2376        {
2377            return first.AREF(second);
2378        }
2379        @Override
2380        public LispObject execute(LispObject first, LispObject second,
2381                                  LispObject third)
2382
2383        {
2384            return checkArray(first).get(new int[] {Fixnum.getValue(second),Fixnum.getValue(third)} );
2385        }
2386        @Override
2387        public LispObject execute(LispObject[] args) {
2388            final AbstractArray array = checkArray(args[0]);
2389            final int[] subs = new int[args.length - 1];
2390            for (int i = subs.length; i-- > 0;) {
2391                subs[i] = Fixnum.getValue(args[i+1]);
2392            }
2393            return array.get(subs);
2394        }
2395    };
2396
2397    // ### aset array subscripts new-element => new-element
2398    private static final Primitive ASET = new pf_aset();
2399    private static final class pf_aset extends Primitive {
2400        pf_aset() {
2401            super("aset", PACKAGE_SYS, true,
2402                  "array subscripts new-element");
2403        }
2404
2405        @Override
2406        public LispObject execute(LispObject first, LispObject second)
2407
2408        {
2409            // Rank zero array.
2410            final ZeroRankArray array;
2411            if (first instanceof ZeroRankArray) {
2412                array = (ZeroRankArray) first;
2413            } else {
2414                return error(new TypeError("The value " +
2415                                           first.princToString() +
2416                                           " is not an array of rank 0."));
2417            }
2418            array.aset(0, second);
2419            return second;
2420        }
2421        @Override
2422        public LispObject execute(LispObject first, LispObject second,
2423                                  LispObject third)
2424
2425        {
2426            first.aset(second, third);
2427            return third;
2428        }
2429        @Override
2430        public LispObject execute(LispObject[] args) {
2431            final AbstractArray array = checkArray(args[0]);
2432            final int nsubs = args.length - 2;
2433            final int[] subs = new int[nsubs];
2434            for (int i = nsubs; i-- > 0;)
2435                subs[i] = Fixnum.getValue(args[i+1]);
2436            final LispObject newValue = args[args.length - 1];
2437            array.set(subs, newValue);
2438            return newValue;
2439        }
2440    };
2441
2442    // ### row-major-aref array index => element
2443    private static final Primitive ROW_MAJOR_AREF = new pf_row_major_aref();
2444    private static final class pf_row_major_aref extends Primitive {
2445        pf_row_major_aref() {
2446            super(Symbol.ROW_MAJOR_AREF, "array index");
2447        }
2448
2449        @Override
2450        public LispObject execute(LispObject first, LispObject second)
2451
2452        {
2453            return checkArray(first).AREF(Fixnum.getValue(second));
2454        }
2455    };
2456
2457    // ### vector
2458    private static final Primitive VECTOR = new pf_vector();
2459    private static final class pf_vector extends Primitive {
2460        pf_vector() {
2461            super(Symbol.VECTOR, "&rest objects");
2462        }
2463
2464        @Override
2465        public LispObject execute(LispObject[] args) {
2466            return new SimpleVector(args);
2467        }
2468    };
2469
2470    // ### fill-pointer
2471    private static final Primitive FILL_POINTER = new pf_fill_pointer();
2472    private static final class pf_fill_pointer extends Primitive {
2473        pf_fill_pointer() {
2474            super(Symbol.FILL_POINTER, "vector");
2475        }
2476
2477        @Override
2478        public LispObject execute(LispObject arg)
2479
2480        {
2481            if (arg instanceof AbstractArray) {
2482                AbstractArray aa = (AbstractArray)arg;
2483                if (aa.hasFillPointer())
2484                    return Fixnum.getInstance(aa.getFillPointer());
2485            }
2486            return type_error(arg, list(Symbol.AND, Symbol.VECTOR,
2487                                        list(Symbol.SATISFIES,
2488                                             Symbol.ARRAY_HAS_FILL_POINTER_P)));
2489        }
2490    };
2491
2492    // ### %set-fill-pointer vector new-fill-pointer
2493    private static final Primitive _SET_FILL_POINTER = new pf__set_fill_pointer();
2494    private static final class pf__set_fill_pointer extends Primitive {
2495        pf__set_fill_pointer() {
2496            super("%set-fill-pointer", PACKAGE_SYS, true);
2497        }
2498
2499        @Override
2500        public LispObject execute(LispObject first, LispObject second)
2501
2502        {
2503
2504            if (first instanceof AbstractVector) {
2505                AbstractVector v = (AbstractVector) first;
2506                if (v.hasFillPointer())
2507                    v.setFillPointer(second);
2508                else
2509                    v.noFillPointer();
2510                return second;
2511            }
2512
2513            return type_error(first, list(Symbol.AND, Symbol.VECTOR,
2514                                          list(Symbol.SATISFIES,
2515                                               Symbol.ARRAY_HAS_FILL_POINTER_P)));
2516        }
2517    };
2518
2519    // ### vector-push new-element vector => index-of-new-element
2520    private static final Primitive VECTOR_PUSH = new pf_vector_push();
2521    private static final class pf_vector_push extends Primitive {
2522        pf_vector_push() {
2523            super(Symbol.VECTOR_PUSH, "new-element vector");
2524        }
2525
2526        @Override
2527        public LispObject execute(LispObject first, LispObject second)
2528
2529        {
2530            final AbstractVector v = checkVector(second);
2531            int fillPointer = v.getFillPointer();
2532            if (fillPointer < 0)
2533                v.noFillPointer();
2534            if (fillPointer >= v.capacity())
2535                return NIL;
2536            v.aset(fillPointer, first);
2537            v.setFillPointer(fillPointer + 1);
2538            return Fixnum.getInstance(fillPointer);
2539        }
2540    };
2541
2542    // ### vector-push-extend new-element vector &optional extension
2543    // => index-of-new-element
2544    private static final Primitive VECTOR_PUSH_EXTEND = new pf_vector_push_extend();
2545    private static final class pf_vector_push_extend extends Primitive {
2546        pf_vector_push_extend() {
2547            super(Symbol.VECTOR_PUSH_EXTEND,
2548                  "new-element vector &optional extension");
2549        }
2550
2551        @Override
2552        public LispObject execute(LispObject first, LispObject second)
2553
2554        {
2555            return second.VECTOR_PUSH_EXTEND(first);
2556        }
2557
2558        @Override
2559        public LispObject execute(LispObject first, LispObject second,
2560                                  LispObject third)
2561
2562        {
2563            return second.VECTOR_PUSH_EXTEND(first, third);
2564        }
2565    };
2566
2567    // ### vector-pop vector => element
2568    private static final Primitive VECTOR_POP = new pf_vector_pop();
2569    private static final class pf_vector_pop extends Primitive {
2570        pf_vector_pop() {
2571            super(Symbol.VECTOR_POP, "vector");
2572        }
2573
2574        @Override
2575        public LispObject execute(LispObject arg) {
2576            final AbstractVector v = checkVector( arg);
2577            int fillPointer = v.getFillPointer();
2578            if (fillPointer < 0)
2579                v.noFillPointer();
2580            if (fillPointer == 0)
2581                error(new LispError("nothing left to pop"));
2582            int newFillPointer = v.checkIndex(fillPointer - 1);
2583            LispObject element = v.AREF(newFillPointer);
2584            v.setFillPointer(newFillPointer);
2585            return element;
2586        }
2587    };
2588
2589    // ### type-of
2590    private static final Primitive TYPE_OF = new pf_type_of();
2591    private static final class pf_type_of extends Primitive {
2592        pf_type_of() {
2593            super(Symbol.TYPE_OF, "object");
2594        }
2595
2596        @Override
2597        public LispObject execute(LispObject arg) {
2598            return arg.typeOf();
2599        }
2600    };
2601
2602    // ### class-of
2603    private static final Primitive CLASS_OF = new pf_class_of();
2604    private static final class pf_class_of extends Primitive {
2605        pf_class_of() {
2606            super(Symbol.CLASS_OF, "object");
2607        }
2608
2609        @Override
2610        public LispObject execute(LispObject arg) {
2611            return arg.classOf();
2612        }
2613    };
2614
2615    // ### simple-typep
2616    private static final Primitive SIMPLE_TYPEP = new pf_simple_typep();
2617    private static final class pf_simple_typep extends Primitive {
2618        pf_simple_typep() {
2619            super("simple-typep", PACKAGE_SYS, true);
2620        }
2621
2622        @Override
2623        public LispObject execute(LispObject first, LispObject second)
2624
2625        {
2626            return first.typep(second);
2627        }
2628    };
2629
2630    // ### function-lambda-expression function =>
2631    // lambda-expression, closure-p, name
2632    private static final Primitive FUNCTION_LAMBDA_EXPRESSION = new pf_function_lambda_expression();
2633    private static final class pf_function_lambda_expression extends Primitive {
2634        pf_function_lambda_expression() {
2635            super(Symbol.FUNCTION_LAMBDA_EXPRESSION, "function");
2636        }
2637
2638        @Override
2639        public LispObject execute(LispObject arg) {
2640            final LispObject value1, value2, value3;
2641            if (arg instanceof CompiledClosure) {
2642                value1 = NIL;
2643                value2 = T;
2644                LispObject name = ((CompiledClosure)arg).getLambdaName();
2645                value3 = name != null ? name : NIL;
2646            } else if (arg instanceof Closure) {
2647                Closure closure = (Closure) arg;
2648                LispObject expr = closure.getBody();
2649                expr = new Cons(closure.getLambdaList(), expr);
2650                expr = new Cons(Symbol.LAMBDA, expr);
2651                value1 = expr;
2652                Environment env = closure.getEnvironment();
2653                if (env == null || env.isEmpty())
2654                    value2 = NIL;
2655                else
2656                    value2 = env; // Return environment as closure-p.
2657                LispObject name = ((Closure)arg).getLambdaName();
2658                value3 = name != null ? name : NIL;
2659            } else if (arg instanceof Function) {
2660                value1 = NIL;
2661                value2 = T;
2662                value3 = ((Function)arg).getLambdaName();
2663            } else if (arg.typep(Symbol.GENERIC_FUNCTION) != NIL) {
2664                value1 = NIL;
2665                value2 = T;
2666                value3 = Symbol.GENERIC_FUNCTION_NAME.execute(arg);
2667            } else if (arg instanceof FuncallableStandardObject) {
2668              return this.execute(((FuncallableStandardObject)arg).function);
2669            } else {
2670              return type_error(arg, Symbol.FUNCTION);
2671            }
2672            return LispThread.currentThread().setValues(value1, value2, value3);
2673        }
2674    };
2675
2676    // ### funcall
2677    // This needs to be public for LispAPI.java.
2678    public static final Primitive FUNCALL = new pf_funcall();
2679    private static final class pf_funcall extends Primitive {
2680        pf_funcall() {
2681            super(Symbol.FUNCALL, "function &rest args");
2682        }
2683
2684        @Override
2685        public LispObject execute() {
2686            return error(new WrongNumberOfArgumentsException(this, 1, -1));
2687        }
2688        @Override
2689        public LispObject execute(LispObject arg) {
2690            return LispThread.currentThread().execute(arg);
2691        }
2692        @Override
2693        public LispObject execute(LispObject first, LispObject second)
2694
2695        {
2696            return LispThread.currentThread().execute(first, second);
2697        }
2698        @Override
2699        public LispObject execute(LispObject first, LispObject second,
2700                                  LispObject third)
2701
2702        {
2703            return LispThread.currentThread().execute(first, second, third);
2704        }
2705        @Override
2706        public LispObject execute(LispObject first, LispObject second,
2707                                  LispObject third, LispObject fourth)
2708
2709        {
2710            return LispThread.currentThread().execute(first, second, third,
2711                    fourth);
2712        }
2713        @Override
2714        public LispObject execute(LispObject first, LispObject second,
2715                                  LispObject third, LispObject fourth,
2716                                  LispObject fifth)
2717
2718        {
2719            return LispThread.currentThread().execute(first, second, third,
2720                    fourth, fifth);
2721        }
2722        @Override
2723        public LispObject execute(LispObject first, LispObject second,
2724                                  LispObject third, LispObject fourth,
2725                                  LispObject fifth, LispObject sixth)
2726
2727        {
2728            return LispThread.currentThread().execute(first, second, third,
2729                    fourth, fifth, sixth);
2730        }
2731        @Override
2732        public LispObject execute(LispObject first, LispObject second,
2733                                  LispObject third, LispObject fourth,
2734                                  LispObject fifth, LispObject sixth,
2735                                  LispObject seventh)
2736
2737        {
2738            return LispThread.currentThread().execute(first, second, third,
2739                    fourth, fifth, sixth,
2740                    seventh);
2741        }
2742        @Override
2743        public LispObject execute(LispObject first, LispObject second,
2744                                  LispObject third, LispObject fourth,
2745                                  LispObject fifth, LispObject sixth,
2746                                  LispObject seventh, LispObject eigth)
2747
2748        {
2749            return LispThread.currentThread().execute(first, second, third,
2750                    fourth, fifth, sixth,
2751                    seventh, eigth);
2752        }
2753        @Override
2754        public LispObject execute(LispObject[] args) {
2755            final int length = args.length - 1; // Number of arguments.
2756            if (length == 8) {
2757                return LispThread.currentThread().execute(args[0], args[1],
2758                        args[2], args[3],
2759                        args[4], args[5],
2760                        args[6], args[7],
2761                        args[8]);
2762            } else {
2763                LispObject[] newArgs = new LispObject[length];
2764                System.arraycopy(args, 1, newArgs, 0, length);
2765                return LispThread.currentThread().execute(args[0], newArgs);
2766            }
2767        }
2768    };
2769
2770    // ### apply
2771    public static final Primitive APPLY = new pf_apply();
2772    private static final class pf_apply extends Primitive {
2773        pf_apply() {
2774            super(Symbol.APPLY, "function &rest args");
2775        }
2776
2777        @Override
2778        public LispObject execute() {
2779            return error(new WrongNumberOfArgumentsException(this, 2, -1));
2780        }
2781        @Override
2782        public LispObject execute(LispObject arg) {
2783            return error(new WrongNumberOfArgumentsException(this, 2, -1));
2784        }
2785        @Override
2786        public LispObject execute(LispObject fun, LispObject args)
2787
2788        {
2789            final LispThread thread = LispThread.currentThread();
2790            final int length = args.length();
2791            switch (length) {
2792            case 0:
2793                return thread.execute(fun);
2794            case 1:
2795                return thread.execute(fun, ((Cons)args).car);
2796            case 2: {
2797                Cons cons = (Cons) args;
2798                return thread.execute(fun, cons.car, ((Cons)cons.cdr).car);
2799            }
2800            case 3:
2801                return thread.execute(fun, args.car(), args.cadr(),
2802                                      args.cdr().cdr().car());
2803            default: {
2804                final LispObject[] funArgs = new LispObject[length];
2805                int j = 0;
2806                while (args != NIL) {
2807                    funArgs[j++] = args.car();
2808                    args = args.cdr();
2809                }
2810                return funcall(fun, funArgs, thread);
2811            }
2812            }
2813        }
2814        @Override
2815        public LispObject execute(LispObject first, LispObject second,
2816                                  LispObject third)
2817
2818        {
2819            if (third.listp()) {
2820                final int numFunArgs = 1 + third.length();
2821                final LispObject[] funArgs = new LispObject[numFunArgs];
2822                funArgs[0] = second;
2823                int j = 1;
2824                while (third != NIL) {
2825                    funArgs[j++] = third.car();
2826                    third = third.cdr();
2827                }
2828                return funcall(first, funArgs, LispThread.currentThread());
2829            }
2830            return type_error(third, Symbol.LIST);
2831        }
2832        @Override
2833        public LispObject execute(final LispObject[] args) {
2834            final int numArgs = args.length;
2835            LispObject spread = args[numArgs - 1];
2836            if (spread.listp()) {
2837                final int numFunArgs = numArgs - 2 + spread.length();
2838                final LispObject[] funArgs = new LispObject[numFunArgs];
2839                int j = 0;
2840                for (int i = 1; i < numArgs - 1; i++)
2841                    funArgs[j++] = args[i];
2842                while (spread != NIL) {
2843                    funArgs[j++] = spread.car();
2844                    spread = spread.cdr();
2845                }
2846                return funcall(args[0], funArgs, LispThread.currentThread());
2847            }
2848            return type_error(spread, Symbol.LIST);
2849        }
2850    };
2851
2852    // ### mapcar
2853    private static final Primitive MAPCAR = new pf_mapcar();
2854    private static final class pf_mapcar extends Primitive {
2855        pf_mapcar() {
2856            super(Symbol.MAPCAR, "function &rest lists");
2857        }
2858
2859        @Override
2860        public LispObject execute(LispObject fun, LispObject list)
2861
2862        {
2863            final LispThread thread = LispThread.currentThread();
2864            LispObject result = NIL;
2865            Cons splice = null;
2866            while (list != NIL) {
2867                Cons cons;
2868                if (list instanceof Cons)
2869                    cons = (Cons) list;
2870                else
2871                    return type_error(list, Symbol.LIST);
2872                LispObject obj = thread.execute(fun, cons.car);
2873                if (splice == null) {
2874                    splice = new Cons(obj, result);
2875                    result = splice;
2876                } else {
2877                    Cons c = new Cons(obj);
2878                    splice.cdr = c;
2879                    splice = c;
2880                }
2881                list = cons.cdr;
2882            }
2883            thread._values = null;
2884            return result;
2885        }
2886        @Override
2887        public LispObject execute(LispObject fun, LispObject list1,
2888                                  LispObject list2)
2889
2890        {
2891            final LispThread thread = LispThread.currentThread();
2892            LispObject result = NIL;
2893            Cons splice = null;
2894            while (list1 != NIL && list2 != NIL) {
2895                LispObject obj =
2896                    thread.execute(fun, list1.car(), list2.car());
2897                if (splice == null) {
2898                    splice = new Cons(obj, result);
2899                    result = splice;
2900                } else {
2901                    Cons cons = new Cons(obj);
2902                    splice.cdr = cons;
2903                    splice = cons;
2904                }
2905                list1 = list1.cdr();
2906                list2 = list2.cdr();
2907            }
2908            thread._values = null;
2909            return result;
2910        }
2911        @Override
2912        public LispObject execute(final LispObject[] args)
2913        {
2914            final int numArgs = args.length;
2915            if (numArgs < 2) {
2916                return error(new WrongNumberOfArgumentsException(this, 2, -1));
2917            }
2918            final LispThread thread = LispThread.currentThread();
2919            final int numFunArgs = numArgs - 1;
2920            final LispObject[] funArgs = new LispObject[numFunArgs];
2921      LispObject result = NIL;
2922      LispObject tail = NIL;
2923      boolean done = false; 
2924            while (!done) {
2925        for (int j = 1; j < numArgs; j++) {
2926    if (args[j] == NIL) {
2927      done = true;
2928                }
2929              }
2930        if (!done) {
2931                for (int j = 0; j < numFunArgs; j++) {
2932                  funArgs[j] = args[j+1].car();
2933                }
2934     
2935                LispObject one = funcall(args[0], funArgs, thread);
2936
2937                if (result == NIL) {
2938                  result = new Cons(one,NIL);
2939                  tail = result;
2940                } else {
2941                  tail.setCdr(new Cons(one,NIL));
2942                  tail = tail.cdr();
2943                }
2944                for (int j = 1; j < numArgs; j++) {
2945                  args[j] = args[j].cdr();
2946                }
2947              }
2948      }
2949            thread._values = null;
2950            return result;
2951        }
2952    };
2953
2954    // ### mapc
2955    private static final Primitive MAPC = new pf_mapc();
2956    private static final class pf_mapc extends Primitive {
2957        pf_mapc() {
2958            super(Symbol.MAPC, "function &rest lists");
2959        }
2960
2961        @Override
2962        public LispObject execute(LispObject fun, LispObject list)
2963
2964        {
2965            final LispThread thread = LispThread.currentThread();
2966            LispObject result = list;
2967            while (list != NIL) {
2968                Cons cons;
2969                if (list instanceof Cons)
2970                    cons = (Cons) list;
2971                else
2972                    return type_error(list, Symbol.LIST);
2973                thread.execute(fun, cons.car);
2974                list = cons.cdr;
2975            }
2976            thread._values = null;
2977            return result;
2978        }
2979        @Override
2980        public LispObject execute(LispObject fun, LispObject list1,
2981                                  LispObject list2)
2982
2983        {
2984            final LispThread thread = LispThread.currentThread();
2985            LispObject result = list1;
2986            while (list1 != NIL && list2 != NIL) {
2987                thread.execute(fun, list1.car(), list2.car());
2988                list1 = ((Cons)list1).cdr;
2989                list2 = ((Cons)list2).cdr;
2990            }
2991            thread._values = null;
2992            return result;
2993        }
2994        @Override
2995        public LispObject execute(final LispObject[] args)
2996
2997        {
2998            final int numArgs = args.length;
2999            if (numArgs < 2) {
3000              return error(new WrongNumberOfArgumentsException(this, 2, -1));
3001            }
3002            final LispThread thread = LispThread.currentThread();
3003            final int numFunArgs = numArgs - 1;
3004      LispObject result = args[1];
3005      boolean done = false;
3006            final LispObject[] funArgs = new LispObject[numFunArgs];
3007            while (!done) {
3008        for (int j = 1; j < numArgs; j++) {
3009    if (args[j] == NIL) {
3010      done = true;
3011                }
3012              }
3013        if (!done) {
3014                for (int j = 0; j < numFunArgs; j++) {
3015                    funArgs[j] = args[j+1].car();
3016                }
3017                funcall(args[0], funArgs, thread);
3018                for (int j = 1; j < numArgs; j++) {
3019                  args[j] = args[j].cdr();
3020                }
3021              }
3022      }
3023            thread._values = null;
3024            return result;
3025        }
3026    };
3027
3028    // ### macroexpand
3029    private static final Primitive MACROEXPAND = new pf_macroexpand();
3030    private static final class pf_macroexpand extends Primitive {
3031        pf_macroexpand() {
3032            super(Symbol.MACROEXPAND, "form &optional env");
3033        }
3034
3035        @Override
3036        public LispObject execute(LispObject form) {
3037            return macroexpand(form,
3038                               new Environment(),
3039                               LispThread.currentThread());
3040        }
3041        @Override
3042        public LispObject execute(LispObject form, LispObject env)
3043
3044        {
3045            return macroexpand(form,
3046                               env != NIL ? checkEnvironment(env) : new Environment(),
3047                               LispThread.currentThread());
3048        }
3049    };
3050
3051    // ### macroexpand-1
3052    private static final Primitive MACROEXPAND_1 = new pf_macroexpand_1();
3053    private static final class pf_macroexpand_1 extends Primitive {
3054        pf_macroexpand_1() {
3055            super(Symbol.MACROEXPAND_1, "form &optional env");
3056        }
3057
3058        @Override
3059        public LispObject execute(LispObject form) {
3060            return macroexpand_1(form,
3061                                 new Environment(),
3062                                 LispThread.currentThread());
3063        }
3064        @Override
3065        public LispObject execute(LispObject form, LispObject env)
3066
3067        {
3068            return macroexpand_1(form,
3069                                 env != NIL ? checkEnvironment(env) : new Environment(),
3070                                 LispThread.currentThread());
3071        }
3072    };
3073
3074    // ### gensym
3075    public static final Primitive GENSYM = new pf_gensym();
3076    private static final class pf_gensym extends Primitive {
3077        pf_gensym() {
3078            super(Symbol.GENSYM, "&optional x");
3079        }
3080
3081        @Override
3082        public LispObject execute() {
3083            return gensym("G", LispThread.currentThread());
3084        }
3085        @Override
3086        public LispObject execute(LispObject arg) {
3087            if (arg instanceof Fixnum) {
3088                int n = ((Fixnum)arg).value;
3089                if (n >= 0) {
3090                    StringBuilder sb = new StringBuilder("G");
3091                    sb.append(n); // Decimal representation.
3092                    return new Symbol(new SimpleString(sb));
3093                }
3094            } else if (arg instanceof Bignum) {
3095                BigInteger n = ((Bignum)arg).value;
3096                if (n.signum() >= 0) {
3097                    StringBuilder sb = new StringBuilder("G");
3098                    sb.append(n.toString()); // Decimal representation.
3099                    return new Symbol(new SimpleString(sb));
3100                }
3101            } else if (arg instanceof AbstractString)
3102                return gensym(arg.getStringValue(), LispThread.currentThread());
3103            return type_error(arg,
3104                              list(Symbol.OR,
3105                                   Symbol.STRING,
3106                                   Symbol.UNSIGNED_BYTE));
3107        }
3108    };
3109
3110    // ### string
3111    private static final Primitive STRING = new pf_string();
3112    private static final class pf_string extends Primitive {
3113        pf_string() {
3114            super(Symbol.STRING, "x");
3115        }
3116
3117        @Override
3118        public LispObject execute(LispObject arg) {
3119            return arg.STRING();
3120        }
3121    };
3122
3123    // ### intern string &optional package => symbol, status
3124    // STATUS is one of :INHERITED, :EXTERNAL, :INTERNAL or NIL.
3125    // "It is implementation-dependent whether the string that becomes the new
3126    // symbol's name is the given string or a copy of it."
3127    private static final Primitive INTERN = new pf_intern();
3128    private static final class pf_intern extends Primitive {
3129        pf_intern() {
3130            super(Symbol.INTERN, "string &optional package");
3131        }
3132
3133        @Override
3134        public LispObject execute(LispObject arg) {
3135            final SimpleString s;
3136            if (arg instanceof SimpleString)
3137                s = (SimpleString) arg;
3138            else
3139                s = new SimpleString(arg.getStringValue());
3140            final LispThread thread = LispThread.currentThread();
3141            Package pkg = (Package) Symbol._PACKAGE_.symbolValue(thread);
3142            return pkg.intern(s, thread);
3143        }
3144        @Override
3145        public LispObject execute(LispObject first, LispObject second)
3146
3147        {
3148            final SimpleString s;
3149            if (first instanceof SimpleString)
3150                s = (SimpleString) first;
3151            else
3152                s = new SimpleString(first.getStringValue());
3153            Package pkg = coerceToPackage(second);
3154            return pkg.intern(s, LispThread.currentThread());
3155        }
3156    };
3157
3158    // ### unintern
3159    // unintern symbol &optional package => generalized-boolean
3160    private static final Primitive UNINTERN = new pf_unintern();
3161    private static final class pf_unintern extends Primitive {
3162        pf_unintern() {
3163            super(Symbol.UNINTERN, "symbol &optional package");
3164        }
3165
3166        @Override
3167        public LispObject execute(LispObject[] args) {
3168            if (args.length == 0 || args.length > 2)
3169                return error(new WrongNumberOfArgumentsException(this, 1, 2));
3170            Symbol symbol = checkSymbol(args[0]);
3171            Package pkg;
3172            if (args.length == 2)
3173                pkg = coerceToPackage(args[1]);
3174            else
3175                pkg = getCurrentPackage();
3176            return pkg.unintern(symbol);
3177        }
3178    };
3179
3180    // ### find-package
3181    private static final Primitive FIND_PACKAGE = new pf_find_package();
3182    private static final class pf_find_package extends Primitive {
3183        pf_find_package() {
3184            super(Symbol.FIND_PACKAGE, "name");
3185        }
3186
3187        @Override
3188        public LispObject execute(LispObject arg) {
3189            if (arg instanceof Package)
3190                return arg;
3191            if (arg instanceof AbstractString) {
3192                Package pkg =
3193                  getCurrentPackage().findPackage(arg.getStringValue());
3194                return pkg != null ? pkg : NIL;
3195            }
3196            if (arg instanceof Symbol) {
3197                Package pkg = getCurrentPackage().findPackage(checkSymbol(arg).getName());
3198                return pkg != null ? pkg : NIL;
3199            }
3200            if (arg instanceof LispCharacter) {
3201                String packageName =
3202                    String.valueOf(new char[] {((LispCharacter)arg).getValue()});
3203                Package pkg = getCurrentPackage().findPackage(packageName);
3204                return pkg != null ? pkg : NIL;
3205            }
3206            return NIL;
3207        }
3208    };
3209
3210    // ### %make-package
3211    // %make-package package-name nicknames use => package
3212    private static final Primitive _MAKE_PACKAGE = new pf__make_package();
3213    private static final class pf__make_package extends Primitive {
3214        pf__make_package() {
3215            super("%make-package", PACKAGE_SYS, false);
3216        }
3217
3218        /**
3219         * This invocation is solely used to be able to create
3220         * a package to bind to *FASL-ANONYMOUS-PACKAGE*
3221         */
3222        @Override
3223        public LispObject execute()
3224
3225        {
3226            return new Package();
3227        }
3228
3229        /**
3230         * This invocation is used by MAKE-PACKAGE to create a package
3231         */
3232        @Override
3233        public LispObject execute(LispObject first, LispObject second,
3234                                  LispObject third)
3235
3236        {
3237            String packageName = javaString(first);
3238            Package currentpkg = getCurrentPackage();
3239            Package pkg = currentpkg.findPackage(packageName);
3240            if (pkg != null)
3241                error(new LispError("Package " + packageName +
3242                                    " already exists."));
3243            LispObject nicknames = checkList(second);
3244            if (nicknames != NIL) {
3245                LispObject list = nicknames;
3246                while (list != NIL) {
3247                    LispObject lispNick = list.car();
3248                    String nick = javaString(lispNick);
3249                    if (currentpkg.findPackage(nick) != null) {
3250                        error(new PackageError("A package named " + nick +
3251                                               " already exists.", lispNick));
3252                    }
3253                    list = list.cdr();
3254                }
3255            }
3256            LispObject use = checkList(third);
3257            if (use != NIL) {
3258                LispObject list = use;
3259                while (list != NIL) {
3260                    LispObject obj = list.car();
3261                    if (obj instanceof Package) {
3262                        // OK.
3263                    } else {
3264                        String s = javaString(obj);
3265                        Package p = currentpkg.findPackage(s);
3266                        if (p == null) {
3267                            error(new LispError(obj.princToString() +
3268                                                " is not the name of a package."));
3269                            return NIL;
3270                        }
3271                    }
3272                    list = list.cdr();
3273                }
3274            }
3275            // Now create the package.
3276            pkg = Packages.createPackage(packageName);
3277            // Add the nicknames.
3278            while (nicknames != NIL) {
3279                String nick = javaString(nicknames.car());
3280                pkg.addNickname(nick);
3281                nicknames = nicknames.cdr();
3282            }
3283            // Create the use list.
3284            while (use != NIL) {
3285                LispObject obj = use.car();
3286                if (obj instanceof Package)
3287                    pkg.usePackage((Package)obj);
3288                else {
3289                    String s = javaString(obj);
3290                    Package p = currentpkg.findPackage(s);
3291                    if (p == null) {
3292                        error(new LispError(obj.princToString() +
3293                                            " is not the name of a package."));
3294                        return NIL;
3295                    }
3296                    pkg.usePackage(p);
3297                }
3298                use = use.cdr();
3299            }
3300            return pkg;
3301        }
3302    };
3303
3304    // ### %in-package
3305    private static final Primitive _IN_PACKAGE = new pf__in_package();
3306    private static final class pf__in_package extends Primitive {
3307        pf__in_package() {
3308            super("%in-package", PACKAGE_SYS, true);
3309        }
3310
3311        @Override
3312        public LispObject execute(LispObject arg) {
3313            final String packageName = javaString(arg);
3314            final Package pkg = getCurrentPackage().findPackage(packageName);
3315            if (pkg == null)
3316                return error(new PackageError("The name " + packageName +
3317                                              " does not designate any package.", arg));
3318            SpecialBinding binding =
3319                LispThread.currentThread().getSpecialBinding(Symbol._PACKAGE_);
3320            if (binding != null)
3321                binding.value = pkg;
3322            else
3323                // No dynamic binding.
3324                Symbol._PACKAGE_.setSymbolValue(pkg);
3325            return pkg;
3326        }
3327    };
3328
3329    // ### use-package packages-to-use &optional package => t
3330    private static final Primitive USE_PACKAGE = new pf_use_package();
3331    private static final class pf_use_package extends Primitive {
3332        pf_use_package() {
3333            super(Symbol.USE_PACKAGE, "packages-to-use &optional package");
3334        }
3335
3336        @Override
3337        public LispObject execute(LispObject[] args) {
3338            if (args.length < 1 || args.length > 2)
3339                return error(new WrongNumberOfArgumentsException(this, 1, 2));
3340            Package pkg;
3341            if (args.length == 2)
3342                pkg = coerceToPackage(args[1]);
3343            else
3344                pkg = getCurrentPackage();
3345            if (args[0].listp()) {
3346                LispObject list = args[0];
3347                while (list != NIL) {
3348                    pkg.usePackage(coerceToPackage(list.car()));
3349                    list = list.cdr();
3350                }
3351            } else
3352                pkg.usePackage(coerceToPackage(args[0]));
3353            return T;
3354        }
3355    };
3356
3357    // ### package-symbols
3358    private static final Primitive PACKAGE_SYMBOLS = new pf_package_symbols();
3359    private static final class pf_package_symbols extends Primitive {
3360        pf_package_symbols() {
3361            super("package-symbols", PACKAGE_SYS, true);
3362        }
3363
3364        @Override
3365        public LispObject execute(LispObject arg) {
3366            return coerceToPackage(arg).getSymbols();
3367        }
3368    };
3369
3370    // ### package-internal-symbols
3371    private static final Primitive PACKAGE_INTERNAL_SYMBOLS = new pf_package_internal_symbols();
3372    private static final class pf_package_internal_symbols extends Primitive {
3373        pf_package_internal_symbols() {
3374            super("package-internal-symbols", PACKAGE_SYS, true);
3375        }
3376
3377        @Override
3378        public LispObject execute(LispObject arg) {
3379            return coerceToPackage(arg).PACKAGE_INTERNAL_SYMBOLS();
3380        }
3381    };
3382
3383    // ### package-external-symbols
3384    private static final Primitive PACKAGE_EXTERNAL_SYMBOLS = new pf_package_external_symbols();
3385    private static final class pf_package_external_symbols extends Primitive {
3386        pf_package_external_symbols() {
3387            super("package-external-symbols", PACKAGE_SYS, true);
3388        }
3389
3390        @Override
3391        public LispObject execute(LispObject arg) {
3392            return coerceToPackage(arg).PACKAGE_EXTERNAL_SYMBOLS();
3393        }
3394    };
3395
3396    // ### package-inherited-symbols
3397    private static final Primitive PACKAGE_INHERITED_SYMBOLS = new pf_package_inherited_symbols();
3398    private static final class pf_package_inherited_symbols extends Primitive {
3399        pf_package_inherited_symbols() {
3400            super("package-inherited-symbols", PACKAGE_SYS, true);
3401        }
3402
3403        @Override
3404        public LispObject execute(LispObject arg) {
3405            return coerceToPackage(arg).PACKAGE_INHERITED_SYMBOLS();
3406        }
3407    };
3408
3409    // ### export symbols &optional package
3410    private static final Primitive EXPORT = new pf_export();
3411    private static final class pf_export extends Primitive {
3412        pf_export() {
3413            super(Symbol.EXPORT, "symbols &optional package");
3414        }
3415
3416        @Override
3417        public LispObject execute(LispObject arg) {
3418            final Package pkg = (Package) Symbol._PACKAGE_.symbolValue();
3419            if (arg instanceof Cons) {
3420                for (LispObject list = arg; list != NIL; list = list.cdr())
3421                    pkg.export(checkSymbol(list.car()));
3422            } else
3423                pkg.export(checkSymbol(arg));
3424            return T;
3425        }
3426
3427        @Override
3428        public LispObject execute(LispObject first, LispObject second)
3429
3430        {
3431            if (first instanceof Cons) {
3432                Package pkg = coerceToPackage(second);
3433                for (LispObject list = first; list != NIL; list = list.cdr())
3434                    pkg.export(checkSymbol(list.car()));
3435            } else
3436                coerceToPackage(second).export(checkSymbol(first));
3437            return T;
3438        }
3439    };
3440
3441    // ### find-symbol string &optional package => symbol, status
3442    private static final Primitive FIND_SYMBOL = new pf_find_symbol();
3443    private static final class pf_find_symbol extends Primitive {
3444        pf_find_symbol() {
3445            super(Symbol.FIND_SYMBOL, "string &optional package");
3446        }
3447
3448        @Override
3449        public LispObject execute(LispObject arg) {
3450            return getCurrentPackage()
3451                   .findSymbol(checkString(arg).getStringValue());
3452        }
3453
3454        @Override
3455        public LispObject execute(LispObject first, LispObject second)
3456
3457        {
3458            return coerceToPackage(second)
3459                   .findSymbol(checkString(first).getStringValue());
3460        }
3461    };
3462
3463    // ### fset name function &optional source-position arglist documentation
3464    // => function
3465    private static final Primitive FSET = new pf_fset();
3466    private static final class pf_fset extends Primitive {
3467        pf_fset() {
3468            super("fset", PACKAGE_SYS, true);
3469        }
3470
3471        @Override
3472        public LispObject execute(LispObject first, LispObject second)
3473
3474        {
3475            return execute(first, second, NIL, NIL, NIL);
3476        }
3477        @Override
3478        public LispObject execute(LispObject first, LispObject second,
3479                                  LispObject third)
3480
3481        {
3482            return execute(first, second, third, NIL, NIL);
3483        }
3484        @Override
3485        public LispObject execute(LispObject first, LispObject second,
3486                                  LispObject third, LispObject fourth)
3487
3488        {
3489            return execute(first, second, third, fourth, NIL);
3490        }
3491        @Override
3492        public LispObject execute(LispObject first, LispObject second,
3493                                  LispObject third, LispObject fourth,
3494                                  LispObject fifth)
3495
3496        {
3497            if (first instanceof Symbol) {
3498                checkRedefinition(first);
3499                Symbol symbol = checkSymbol(first);
3500                symbol.setSymbolFunction(second);
3501                final LispThread thread = LispThread.currentThread();
3502                LispObject sourcePathname = _SOURCE_.symbolValue(thread);
3503                LispObject sourcePosition = third;
3504                if (sourcePathname != NIL)
3505                    sourcePosition = _SOURCE_POSITION_.symbolValue(thread);
3506                if (sourcePathname == NIL)
3507                    sourcePathname = Keyword.TOP_LEVEL;
3508                if (sourcePathname != Keyword.TOP_LEVEL)
3509                    put(symbol, Symbol._SOURCE, new Cons(sourcePathname, third));
3510                else
3511                    put(symbol, Symbol._SOURCE, sourcePathname);
3512            } else if (isValidSetfFunctionName(first)) {
3513                // SETF function
3514                checkRedefinition(first);
3515                Symbol symbol = checkSymbol(first.cadr());
3516                put(symbol, Symbol.SETF_FUNCTION, second);
3517            } else
3518                return type_error(first, FUNCTION_NAME);
3519            if (second instanceof Operator) {
3520                Operator op = (Operator) second;
3521                op.setLambdaName(first);
3522                if (fourth != NIL)
3523                    op.setLambdaList(fourth);
3524                if (fifth != NIL)
3525                    op.setDocumentation(Symbol.FUNCTION, fifth);
3526            }
3527            return second;
3528        }
3529    };
3530
3531    // ### %set-symbol-plist
3532    private static final Primitive _SET_SYMBOL_PLIST = new pf__set_symbol_plist();
3533    private static final class pf__set_symbol_plist extends Primitive {
3534        pf__set_symbol_plist() {
3535            super("%set-symbol-plist", PACKAGE_SYS, false);
3536        }
3537
3538        @Override
3539        public LispObject execute(LispObject first, LispObject second)
3540
3541        {
3542            checkSymbol(first).setPropertyList(checkList(second));
3543            return second;
3544        }
3545    };
3546
3547    // ### getf plist indicator &optional default => value
3548    private static final Primitive GETF = new pf_getf();
3549    private static final class pf_getf extends Primitive {
3550        pf_getf() {
3551            super(Symbol.GETF, "plist indicator &optional default");
3552        }
3553
3554        @Override
3555        public LispObject execute(LispObject plist, LispObject indicator)
3556
3557        {
3558            return getf(plist, indicator, NIL);
3559        }
3560        @Override
3561        public LispObject execute(LispObject plist, LispObject indicator,
3562                                  LispObject defaultValue)
3563
3564        {
3565            return getf(plist, indicator, defaultValue);
3566        }
3567    };
3568
3569    // ### get symbol indicator &optional default => value
3570    private static final Primitive GET = new pf_get();
3571    private static final class pf_get extends Primitive {
3572        pf_get() {
3573            super(Symbol.GET, "symbol indicator &optional default");
3574        }
3575
3576        @Override
3577        public LispObject execute(LispObject symbol, LispObject indicator)
3578
3579        {
3580            return get(symbol, indicator, NIL);
3581        }
3582        @Override
3583        public LispObject execute(LispObject symbol, LispObject indicator,
3584                                  LispObject defaultValue)
3585
3586        {
3587            return get(symbol, indicator, defaultValue);
3588        }
3589    };
3590
3591    // ### put symbol indicator value => value
3592    public static final Primitive PUT = new pf_put();
3593    private static final class pf_put extends Primitive {
3594        pf_put() {
3595            super("put", PACKAGE_SYS, true);
3596        }
3597
3598        @Override
3599        public LispObject execute(LispObject symbol, LispObject indicator,
3600                                  LispObject value)
3601
3602        {
3603            return put(checkSymbol(symbol), indicator, value);
3604        }
3605        @Override
3606        public LispObject execute(LispObject symbol, LispObject indicator,
3607                                  LispObject defaultValue, LispObject value)
3608
3609        {
3610            return put(checkSymbol(symbol), indicator, value);
3611        }
3612    };
3613
3614    // ### macrolet
3615    private static final SpecialOperator MACROLET = new sf_macrolet();
3616    private static final class sf_macrolet extends SpecialOperator {
3617        sf_macrolet() {
3618            super(Symbol.MACROLET, "definitions &rest body");
3619        }
3620
3621        @Override
3622        public LispObject execute(LispObject args, Environment env)
3623
3624        {
3625            LispObject defs = checkList(args.car());
3626            final LispThread thread = LispThread.currentThread();
3627            final SpecialBindingsMark mark = thread.markSpecialBindings();
3628
3629            Environment ext = new Environment(env);
3630            thread.envStack.push(ext);
3631            try {
3632                while (defs != NIL) {
3633                    LispObject def = checkList(defs.car());
3634                    Symbol symbol = checkSymbol(def.car());
3635                    Symbol make_expander_for_macrolet =
3636                        PACKAGE_SYS.intern("MAKE-MACRO-EXPANDER");
3637                    LispObject expander =
3638                        make_expander_for_macrolet.execute(def);
3639                    Closure expansionFunction = new Closure(expander, env);
3640                    MacroObject macroObject =
3641                        new MacroObject(symbol, expansionFunction);
3642                    ext.addFunctionBinding(symbol, macroObject);
3643                    defs = defs.cdr();
3644                }
3645                return progn(ext.processDeclarations(args.cdr()), ext, thread);
3646            }
3647            finally {
3648                thread.resetSpecialBindings(mark);
3649                while (thread.envStack.pop() != ext) {};
3650            }
3651        }
3652    };
3653
3654    private static final Primitive MAKE_MACRO_EXPANDER = new pf_make_macro_expander();
3655    private static final class pf_make_macro_expander extends Primitive {
3656        pf_make_macro_expander() {
3657            super("make-macro-expander", PACKAGE_SYS, true, "definition");
3658        }
3659
3660        @Override
3661        public LispObject execute(LispObject definition)
3662
3663        {
3664            /* Create an expansion function
3665             * `(lambda (,formArg ,envArg)
3666             *     (apply (function (macro-function ,lambdaList
3667             *                         (block ,symbol ,@body)))
3668             *            (cdr ,formArg)))
3669             */
3670            Symbol symbol = checkSymbol(definition.car());
3671            LispObject lambdaList = definition.cadr();
3672            LispObject body = definition.cddr();
3673            LispObject block =
3674                new Cons(Symbol.BLOCK, new Cons(symbol, body));
3675            LispObject toBeApplied =
3676                list(Symbol.FUNCTION, list(Symbol.MACRO_FUNCTION, lambdaList, block));
3677            final LispThread thread = LispThread.currentThread();
3678            LispObject formArg = gensym("WHOLE-", thread);
3679            LispObject envArg = gensym("ENVIRONMENT-", thread); // Ignored.
3680            LispObject expander =
3681                list(Symbol.LAMBDA, list(formArg, envArg),
3682                     list(Symbol.APPLY, toBeApplied,
3683                          list(Symbol.CDR, formArg)));
3684            return expander;
3685        }
3686    };
3687
3688    // ### tagbody
3689    private static final SpecialOperator TAGBODY = new sf_tagbody();
3690    private static final class sf_tagbody extends SpecialOperator {
3691        sf_tagbody() {
3692            super(Symbol.TAGBODY, "&rest statements");
3693        }
3694
3695        @Override
3696        public LispObject execute(LispObject args, Environment env)
3697
3698        {
3699            Environment ext = new Environment(env);
3700            LispThread thread = LispThread.currentThread();
3701            try {
3702                thread.envStack.push(ext);
3703                return processTagBody(args, preprocessTagBody(args, ext), ext);
3704            }
3705            finally {
3706                ext.inactive = true;
3707                while (thread.envStack.pop() != ext) {};
3708            }
3709        }
3710    };
3711
3712    // ### go
3713    private static final SpecialOperator GO = new sf_go();
3714    private static final class sf_go extends SpecialOperator {
3715        sf_go() {
3716            super(Symbol.GO, "tag");
3717        }
3718
3719        @Override
3720        public LispObject execute(LispObject args, Environment env)
3721
3722        {
3723            if (args.length() != 1)
3724                return error(new WrongNumberOfArgumentsException(this, 1));
3725            Binding binding = env.getTagBinding(args.car());
3726            if (binding == null)
3727                return error(new ControlError("No tag named " +
3728                                              args.car().princToString() +
3729                                              " is currently visible."));
3730
3731            return nonLocalGo(binding, args.car());
3732        }
3733    };
3734
3735    // ### block
3736    private static class BlockMarker extends LispObject implements Serializable {}
3737
3738    private static final SpecialOperator BLOCK = new sf_block();
3739    private static final class sf_block extends SpecialOperator {
3740        sf_block() {
3741            super(Symbol.BLOCK, "name &rest forms");
3742        }
3743
3744        @Override
3745        public LispObject execute(LispObject args, Environment env)
3746
3747        {
3748            if (args == NIL)
3749                return error(new WrongNumberOfArgumentsException(this, 1, -1));
3750            LispObject tag;
3751            tag = checkSymbol(args.car());
3752            LispObject body = ((Cons)args).cdr();
3753            Environment ext = new Environment(env);
3754            final LispObject block = new BlockMarker();
3755            ext.addBlock(tag, block);
3756            LispObject result = NIL;
3757            final LispThread thread = LispThread.currentThread();
3758            try {
3759                thread.envStack.push(ext);
3760                return progn(body, ext, thread);
3761            } catch (Return ret) {
3762                if (ret.getBlock() == block) {
3763                    return ret.getResult();
3764                }
3765                throw ret;
3766            }
3767            finally {
3768                while (thread.envStack.pop() != ext) {};
3769                ext.inactive = true;
3770            }
3771        }
3772    };
3773
3774    // ### return-from
3775    private static final SpecialOperator RETURN_FROM = new sf_return_from();
3776    private static final class sf_return_from extends SpecialOperator {
3777        sf_return_from() {
3778            super(Symbol.RETURN_FROM, "name &optional value");
3779        }
3780
3781        @Override
3782        public LispObject execute(LispObject args, Environment env)
3783
3784        {
3785            final int length = args.length();
3786            if (length < 1 || length > 2)
3787                return error(new WrongNumberOfArgumentsException(this, 1, 2));
3788            Symbol symbol;
3789            symbol = checkSymbol(args.car());
3790
3791            return nonLocalReturn(env.getBlockBinding(symbol), symbol,
3792                                  (length == 2) ? eval(args.cadr(), env,
3793                                                       LispThread.currentThread())
3794                                  : NIL);
3795        }
3796    };
3797
3798    // ### catch
3799    private static final SpecialOperator CATCH = new sf_catch();
3800    private static final class sf_catch extends SpecialOperator {
3801        sf_catch() {
3802            super(Symbol.CATCH, "tag &body body");
3803        }
3804
3805        @Override
3806        public LispObject execute(LispObject args, Environment env)
3807
3808        {
3809            if (args.length() < 1)
3810                return error(new WrongNumberOfArgumentsException(this, 1, -1));
3811            final LispThread thread = LispThread.currentThread();
3812            LispObject tag = eval(args.car(), env, thread);
3813            thread.pushCatchTag(tag);
3814            LispObject body = args.cdr();
3815            LispObject result = NIL;
3816            Environment ext = new Environment(env,Keyword.CATCH,tag);
3817            try {
3818                thread.envStack.push(ext);
3819                return progn(body, env, thread);
3820            } catch (Throw t) {
3821                if (t.tag == tag) {
3822                    return t.getResult(thread);
3823                }
3824                throw t;
3825            } catch (Return ret) {
3826                throw ret;
3827            }
3828            finally {
3829                while (thread.envStack.pop() != ext) {};
3830                thread.popCatchTag();
3831            }
3832        }
3833    };
3834
3835    // ### throw
3836    private static final SpecialOperator THROW = new sf_throw();
3837    private static final class sf_throw extends SpecialOperator {
3838        sf_throw() {
3839            super(Symbol.THROW, "tag result");
3840        }
3841
3842        @Override
3843        public LispObject execute(LispObject args, Environment env)
3844
3845        {
3846            if (args.length() != 2)
3847                return error(new WrongNumberOfArgumentsException(this, 2));
3848            final LispThread thread = LispThread.currentThread();
3849            thread.throwToTag(eval(args.car(), env, thread),
3850                              eval(args.cadr(), env, thread));
3851            // Not reached.
3852            return NIL;
3853        }
3854    };
3855
3856    // ### unwind-protect
3857    private static final SpecialOperator UNWIND_PROTECT = new sf_unwind_protect();
3858    private static final class sf_unwind_protect extends SpecialOperator {
3859        sf_unwind_protect() {
3860            super(Symbol.UNWIND_PROTECT, "protected &body cleanup");
3861        }
3862
3863        @Override
3864        public LispObject execute(LispObject args, Environment env)
3865
3866        {
3867            final LispThread thread = LispThread.currentThread();
3868            LispObject result;
3869            LispObject[] values;
3870            try {
3871                result = eval(args.car(), env, thread);
3872            }
3873            finally {
3874                values = thread._values;
3875                LispObject body = args.cdr();
3876                while (body != NIL) {
3877                    eval(body.car(), env, thread);
3878                    body = ((Cons)body).cdr;
3879                }
3880                thread._values = values;
3881            }
3882            if (values != null)
3883                thread.setValues(values);
3884            else
3885                thread._values = null;
3886            return result;
3887        }
3888    };
3889
3890    // ### eval-when
3891    private static final SpecialOperator EVAL_WHEN = new sf_eval_when();
3892    private static final class sf_eval_when extends SpecialOperator {
3893        sf_eval_when() {
3894            super(Symbol.EVAL_WHEN, "situations &rest forms");
3895        }
3896
3897        @Override
3898        public LispObject execute(LispObject args, Environment env)
3899
3900        {
3901            LispObject situations = args.car();
3902            if (situations != NIL) {
3903                if (memq(Keyword.EXECUTE, situations) ||
3904                        memq(Symbol.EVAL, situations)) {
3905                    return progn(args.cdr(), env, LispThread.currentThread());
3906                }
3907            }
3908            return NIL;
3909        }
3910    };
3911
3912    // ### multiple-value-bind
3913    // multiple-value-bind (var*) values-form declaration* form*
3914    // Should be a macro.
3915    private static final SpecialOperator MULTIPLE_VALUE_BIND = new sf_multiple_value_bind();
3916    private static final class sf_multiple_value_bind extends SpecialOperator {
3917        sf_multiple_value_bind() {
3918            super(Symbol.MULTIPLE_VALUE_BIND,
3919                  "vars value-form &body body");
3920        }
3921
3922        @Override
3923        public LispObject execute(LispObject args, Environment env)
3924
3925        {
3926            LispObject vars = args.car();
3927            args = args.cdr();
3928            LispObject valuesForm = args.car();
3929            LispObject body = args.cdr();
3930            final LispThread thread = LispThread.currentThread();
3931            LispObject value = eval(valuesForm, env, thread);
3932            LispObject[] values = thread._values;
3933            if (values == null) {
3934                // eval() did not return multiple values.
3935                values = new LispObject[1];
3936                values[0] = value;
3937            }
3938            // Process declarations.
3939            LispObject bodyAndDecls = parseBody(body, false);
3940            LispObject specials = parseSpecials(bodyAndDecls.NTH(1));
3941            body = bodyAndDecls.car();
3942
3943            final SpecialBindingsMark mark = thread.markSpecialBindings();
3944            final Environment ext = new Environment(env);
3945            int i = 0;
3946            LispObject var = vars.car();
3947            while (var != NIL) {
3948                final Symbol sym;
3949
3950                sym =  checkSymbol(var);
3951
3952                LispObject val = i < values.length ? values[i] : NIL;
3953                if (specials != NIL && memq(sym, specials)) {
3954                    thread.bindSpecial(sym, val);
3955                    ext.declareSpecial(sym);
3956                } else if (sym.isSpecialVariable()) {
3957                    thread.bindSpecial(sym, val);
3958                } else
3959                    ext.bind(sym, val);
3960                vars = vars.cdr();
3961                var = vars.car();
3962                ++i;
3963            }
3964            // Make sure free special declarations are visible in the body.
3965            // "The scope of free declarations specifically does not include
3966            // initialization forms for bindings established by the form
3967            // containing the declarations." (3.3.4)
3968            while (specials != NIL) {
3969                Symbol symbol = (Symbol) specials.car();
3970                ext.declareSpecial(symbol);
3971                specials = ((Cons)specials).cdr;
3972            }
3973            thread._values = null;
3974            LispObject result = NIL;
3975            try {
3976                thread.envStack.push(ext);
3977                result  = progn(body, ext, thread);
3978            }
3979            finally {
3980                thread.resetSpecialBindings(mark);
3981                while (thread.envStack.pop() != ext) {};
3982            }
3983            return result;
3984        }
3985    };
3986
3987    // ### multiple-value-prog1
3988    private static final SpecialOperator MULTIPLE_VALUE_PROG1 = new sf_multiple_value_prog1();
3989    private static final class sf_multiple_value_prog1 extends SpecialOperator {
3990        sf_multiple_value_prog1() {
3991            super(Symbol.MULTIPLE_VALUE_PROG1,
3992                  "values-form &rest forms");
3993        }
3994
3995        @Override
3996        public LispObject execute(LispObject args, Environment env)
3997
3998        {
3999            if (args.length() == 0)
4000                return error(new WrongNumberOfArgumentsException(this, 1, -1));
4001            final LispThread thread = LispThread.currentThread();
4002            LispObject result = eval(args.car(), env, thread);
4003            LispObject[] values = thread._values;
4004            while ((args = args.cdr()) != NIL)
4005                eval(args.car(), env, thread);
4006            if (values != null)
4007                thread.setValues(values);
4008            else
4009                thread._values = null;
4010            return result;
4011        }
4012    };
4013
4014    // ### multiple-value-call
4015    private static final SpecialOperator MULTIPLE_VALUE_CALL = new sf_multiple_value_call();
4016    private static final class sf_multiple_value_call extends SpecialOperator {
4017        sf_multiple_value_call() {
4018            super(Symbol.MULTIPLE_VALUE_CALL, "fun &rest args");
4019        }
4020
4021        @Override
4022        public LispObject execute(LispObject args, Environment env)
4023
4024        {
4025            if (args.length() == 0)
4026                return error(new WrongNumberOfArgumentsException(this, 1, -1));
4027            final LispThread thread = LispThread.currentThread();
4028            LispObject function;
4029            LispObject obj = eval(args.car(), env, thread);
4030            args = args.cdr();
4031            if (obj instanceof Symbol) {
4032                function = obj.getSymbolFunction();
4033                if (function == null)
4034                    error(new UndefinedFunction(obj));
4035            } else if (obj instanceof Function) {
4036                function = obj;
4037            } else {
4038                error(new LispError(obj.princToString() +
4039                                    " is not a function name."));
4040                return NIL;
4041            }
4042            ArrayList<LispObject> arrayList = new ArrayList<LispObject>();
4043            while (args != NIL) {
4044                LispObject form = args.car();
4045                LispObject result = eval(form, env, thread);
4046                LispObject[] values = thread._values;
4047                if (values != null) {
4048                    for (int i = 0; i < values.length; i++)
4049                        arrayList.add(values[i]);
4050                } else
4051                    arrayList.add(result);
4052                args = ((Cons)args).cdr;
4053            }
4054            LispObject[] argv = new LispObject[arrayList.size()];
4055            arrayList.toArray(argv);
4056            return funcall(function, argv, thread);
4057        }
4058    };
4059
4060    // ### and
4061    // Should be a macro.
4062    private static final SpecialOperator AND = new sf_and();
4063    private static final class sf_and extends SpecialOperator {
4064        sf_and() {
4065            super(Symbol.AND, "&rest forms");
4066        }
4067
4068        @Override
4069        public LispObject execute(LispObject args, Environment env)
4070
4071        {
4072            final LispThread thread = LispThread.currentThread();
4073            LispObject result = T;
4074            while (args != NIL) {
4075                result = eval(args.car(), env, thread);
4076                if (result == NIL) {
4077                    if (((Cons)args).cdr != NIL) {
4078                        // Not the last form.
4079                        thread._values = null;
4080                    }
4081                    break;
4082                }
4083                args = ((Cons)args).cdr;
4084            }
4085            return result;
4086        }
4087    };
4088
4089    // ### or
4090    // Should be a macro.
4091    private static final SpecialOperator OR = new sf_or();
4092    private static final class sf_or extends SpecialOperator {
4093        sf_or() {
4094            super(Symbol.OR, "&rest forms");
4095        }
4096
4097        @Override
4098        public LispObject execute(LispObject args, Environment env)
4099
4100        {
4101            final LispThread thread = LispThread.currentThread();
4102            LispObject result = NIL;
4103            while (args != NIL) {
4104                result = eval(args.car(), env, thread);
4105                if (result != NIL) {
4106                    if (((Cons)args).cdr != NIL) {
4107                        // Not the last form.
4108                        thread._values = null;
4109                    }
4110                    break;
4111                }
4112                args = ((Cons)args).cdr;
4113            }
4114            return result;
4115        }
4116    };
4117
4118    // ### multiple-value-list form => list
4119    // Evaluates form and creates a list of the multiple values it returns.
4120    // Should be a macro.
4121    private static final SpecialOperator MULTIPLE_VALUE_LIST = new sf_multiple_value_list();
4122    private static final class sf_multiple_value_list extends SpecialOperator {
4123        sf_multiple_value_list() {
4124            super(Symbol.MULTIPLE_VALUE_LIST, "value-form");
4125        }
4126
4127        @Override
4128        public LispObject execute(LispObject args, Environment env)
4129
4130        {
4131            if (args.length() != 1)
4132                return error(new WrongNumberOfArgumentsException(this, 1));
4133            final LispThread thread = LispThread.currentThread();
4134            LispObject result = eval(((Cons)args).car, env, thread);
4135            LispObject[] values = thread._values;
4136            if (values == null)
4137                return new Cons(result);
4138            thread._values = null;
4139            LispObject list = NIL;
4140            for (int i = values.length; i-- > 0;)
4141                list = new Cons(values[i], list);
4142            return list;
4143        }
4144    };
4145
4146    // ### nth-value n form => object
4147    // Evaluates n and then form and returns the nth value returned by form, or
4148    // NIL if n >= number of values returned.
4149    // Should be a macro.
4150    private static final SpecialOperator NTH_VALUE = new sf_nth_value();
4151    private static final class sf_nth_value extends SpecialOperator {
4152        sf_nth_value() {
4153            super(Symbol.NTH_VALUE, "n form");
4154        }
4155
4156        @Override
4157        public LispObject execute(LispObject args, Environment env)
4158
4159        {
4160            if (args.length() != 2)
4161                return error(new WrongNumberOfArgumentsException(this, 2));
4162            final LispThread thread = LispThread.currentThread();
4163            int n = Fixnum.getValue(eval(args.car(), env, thread));
4164            if (n < 0)
4165                n = 0;
4166            LispObject result = eval(args.cadr(), env, thread);
4167            LispObject[] values = thread._values;
4168            thread._values = null;
4169            if (values == null) {
4170                // A single value was returned.
4171                return n == 0 ? result : NIL;
4172            }
4173            if (n < values.length)
4174                return values[n];
4175            return NIL;
4176        }
4177    };
4178
4179    // ### call-count
4180    private static final Primitive CALL_COUNT = new pf_call_count();
4181    private static final class pf_call_count extends Primitive {
4182        pf_call_count() {
4183            super("call-count", PACKAGE_SYS, true);
4184        }
4185
4186        @Override
4187        public LispObject execute(LispObject arg) {
4188            return Fixnum.getInstance(arg.getCallCount());
4189        }
4190    };
4191
4192    // ### set-call-count
4193    private static final Primitive SET_CALL_COUNT = new pf_set_call_count();
4194    private static final class pf_set_call_count extends Primitive {
4195        pf_set_call_count() {
4196            super("set-call-count", PACKAGE_SYS, true);
4197        }
4198
4199        @Override
4200        public LispObject execute(LispObject first, LispObject second)
4201
4202        {
4203            first.setCallCount(Fixnum.getValue(second));
4204            return second;
4205        }
4206    };
4207
4208    // ### hot-count
4209    private static final Primitive HOT_COUNT = new pf_hot_count();
4210    private static final class pf_hot_count extends Primitive {
4211        pf_hot_count() {
4212            super("hot-count", PACKAGE_SYS, true);
4213        }
4214
4215        @Override
4216        public LispObject execute(LispObject arg) {
4217            return Fixnum.getInstance(arg.getHotCount());
4218        }
4219    };
4220
4221    // ### set-hot-count
4222    private static final Primitive SET_HOT_COUNT = new pf_set_hot_count();
4223    private static final class pf_set_hot_count extends Primitive {
4224        pf_set_hot_count() {
4225            super("set-hot-count", PACKAGE_SYS, true);
4226        }
4227
4228        @Override
4229        public LispObject execute(LispObject first, LispObject second)
4230
4231        {
4232            first.setHotCount(Fixnum.getValue(second));
4233            return second;
4234        }
4235    };
4236
4237    // ### lambda-name
4238    private static final Primitive LAMBDA_NAME = new pf_lambda_name();
4239    private static final class pf_lambda_name extends Primitive {
4240        pf_lambda_name() {
4241            super("lambda-name", PACKAGE_SYS, true);
4242        }
4243
4244        @Override
4245        public LispObject execute(LispObject arg) {
4246            if (arg instanceof Operator) {
4247                return ((Operator)arg).getLambdaName();
4248            }
4249            if (arg.typep(Symbol.GENERIC_FUNCTION) != NIL) {
4250                return Symbol.GENERIC_FUNCTION_NAME.execute(arg);
4251            }
4252            if (arg instanceof FuncallableStandardObject) {
4253              return this.execute(((FuncallableStandardObject)arg).function);
4254            }
4255            return type_error(arg, Symbol.FUNCTION);
4256        }
4257    };
4258
4259    // ### %set-lambda-name
4260    private static final Primitive _SET_LAMBDA_NAME = new pf__set_lambda_name();
4261    private static final class pf__set_lambda_name extends Primitive {
4262        pf__set_lambda_name() {
4263            super("%set-lambda-name", PACKAGE_SYS, false);
4264        }
4265
4266        @Override
4267        public LispObject execute(LispObject first, LispObject second)
4268
4269        {
4270            if (first instanceof Operator) {
4271                ((Operator)first).setLambdaName(second);
4272                return second;
4273            }
4274            // KLUDGE: this isn't fully general, but lots of other stuff
4275            // will break for generic functions that aren't subclasses
4276            // of standard-generic-function as well.
4277            if (first.typep(Symbol.STANDARD_GENERIC_FUNCTION) != NIL) {
4278                ((StandardObject)first).setInstanceSlotValue(Symbol.NAME, second);
4279                return second;
4280            }
4281            if (first instanceof FuncallableStandardObject) {
4282              return this.execute(((FuncallableStandardObject)first).function, second);
4283            }
4284            return type_error(first, Symbol.FUNCTION);
4285        }
4286    };
4287
4288    // ### shrink-vector vector new-size => vector
4289    // Destructively alters the vector, changing its length to NEW-SIZE, which
4290    // must be less than or equal to its current length.
4291    // shrink-vector vector new-size => vector
4292    private static final Primitive SHRINK_VECTOR = new pf_shrink_vector();
4293    private static final class pf_shrink_vector extends Primitive {
4294        pf_shrink_vector() {
4295            super("shrink-vector", PACKAGE_SYS, true, "vector new-size");
4296        }
4297
4298        @Override
4299        public LispObject execute(LispObject first, LispObject second)
4300
4301        {
4302            checkVector(first).shrink(Fixnum.getValue(second));
4303            return first;
4304        }
4305    };
4306
4307    // ### subseq sequence start &optional end
4308    private static final Primitive SUBSEQ = new pf_subseq();
4309    private static final class pf_subseq extends Primitive {
4310        pf_subseq() {
4311            super(PACKAGE_SYS.intern("%SUBSEQ"), "sequence start &optional end");
4312        }
4313
4314        @Override
4315        public LispObject execute(LispObject first, LispObject second)
4316
4317        {
4318            return execute(first, second, NIL);
4319        }
4320
4321        @Override
4322        public LispObject execute(LispObject first, LispObject second,
4323                                  LispObject third)
4324
4325        {
4326            final int start = Fixnum.getValue(second);
4327            if (start < 0) {
4328                StringBuilder sb = new StringBuilder("Bad start index (");
4329                sb.append(start);
4330                sb.append(").");
4331                error(new TypeError(sb.toString()));
4332            }
4333            int end;
4334            if (third != NIL) {
4335                end = Fixnum.getValue(third);
4336                if (start > end) {
4337                    StringBuilder sb = new StringBuilder("Start index (");
4338                    sb.append(start);
4339                    sb.append(") is greater than end index (");
4340                    sb.append(end);
4341                    sb.append(") for SUBSEQ.");
4342                    error(new TypeError(sb.toString()));
4343                }
4344            } else
4345                end = -1;
4346            if (first.listp())
4347                return list_subseq(first, start, end);
4348            if (first instanceof AbstractVector) {
4349                final AbstractVector v = (AbstractVector) first;
4350                if (end < 0)
4351                    end = v.length();
4352                if (start > end) {
4353                    StringBuilder sb = new StringBuilder("Start index (");
4354                    sb.append(start);
4355                    sb.append(") is greater than length of vector (");
4356                    sb.append(end);
4357                    sb.append(") for SUBSEQ.");
4358                    error(new TypeError(sb.toString()));
4359                }
4360                return v.subseq(start, end);
4361            }
4362            return type_error(first, Symbol.SEQUENCE);
4363        }
4364    };
4365
4366    static final LispObject list_subseq(LispObject list, int start,
4367            int end)
4368
4369    {
4370        int index = 0;
4371        LispObject result = NIL;
4372        while (list != NIL) {
4373            if (end >= 0 && index == end)
4374                return result.nreverse();
4375            if (index++ >= start)
4376                result = new Cons(list.car(), result);
4377            list = list.cdr();
4378        }
4379        return result.nreverse();
4380    }
4381
4382    // ### list
4383    private static final Primitive LIST = new pf_list();
4384    private static final class pf_list extends Primitive {
4385        pf_list() {
4386            super(Symbol.LIST, "&rest objects");
4387        }
4388
4389        @Override
4390        public LispObject execute() {
4391            return NIL;
4392        }
4393        @Override
4394        public LispObject execute(LispObject arg) {
4395            return new Cons(arg);
4396        }
4397        @Override
4398        public LispObject execute(LispObject first, LispObject second) {
4399            return new Cons(first, new Cons(second));
4400        }
4401        @Override
4402        public LispObject execute(LispObject first, LispObject second,
4403                                  LispObject third) {
4404            return new Cons(first, new Cons(second, new Cons(third)));
4405        }
4406        @Override
4407        public LispObject execute(LispObject first, LispObject second,
4408                                  LispObject third, LispObject fourth) {
4409            return new Cons(first,
4410                            new Cons(second,
4411                                     new Cons(third,
4412                                              new Cons(fourth))));
4413        }
4414        @Override
4415        public LispObject execute(LispObject[] args) {
4416            LispObject result = NIL;
4417            for (int i = args.length; i-- > 0;)
4418                result = new Cons(args[i], result);
4419            return result;
4420        }
4421    };
4422
4423    // ### list*
4424    private static final Primitive LIST_STAR = new pf_list_star();
4425    private static final class pf_list_star extends Primitive {
4426        pf_list_star() {
4427            super(Symbol.LIST_STAR, "&rest objects");
4428        }
4429
4430        @Override
4431        public LispObject execute() {
4432            return error(new WrongNumberOfArgumentsException(this, 1, -1));
4433        }
4434        @Override
4435        public LispObject execute(LispObject arg) {
4436            return arg;
4437        }
4438        @Override
4439        public LispObject execute(LispObject first, LispObject second)
4440
4441        {
4442            return new Cons(first, second);
4443        }
4444        @Override
4445        public LispObject execute(LispObject first, LispObject second,
4446                                  LispObject third)
4447
4448        {
4449            return new Cons(first, new Cons(second, third));
4450        }
4451        @Override
4452        public LispObject execute(LispObject first, LispObject second,
4453                                  LispObject third, LispObject fourth)
4454
4455        {
4456            return new Cons(first,
4457                            new Cons(second,
4458                                     new Cons(third, fourth)));
4459        }
4460        @Override
4461        public LispObject execute(LispObject[] args) {
4462            int i = args.length - 1;
4463            LispObject result = args[i];
4464            while (i-- > 0)
4465                result = new Cons(args[i], result);
4466            return result;
4467        }
4468    };
4469
4470    // ### nreverse
4471    public static final Primitive NREVERSE = new pf_nreverse();
4472    private static final class pf_nreverse extends Primitive {
4473        pf_nreverse() {
4474            super("%NREVERSE", PACKAGE_SYS, false, "sequence");
4475        }
4476
4477        @Override
4478        public LispObject execute (LispObject arg) {
4479            return arg.nreverse();
4480        }
4481    };
4482
4483    // ### nreconc
4484    private static final Primitive NRECONC = new pf_nreconc();
4485    private static final class pf_nreconc extends Primitive {
4486        pf_nreconc() {
4487            super(Symbol.NRECONC, "list tail");
4488        }
4489
4490        @Override
4491        public LispObject execute(LispObject list, LispObject obj)
4492
4493        {
4494            if (list instanceof Cons) {
4495                LispObject list3 = list.cdr();
4496                if (list3 instanceof Cons) {
4497                    if (list3.cdr() instanceof Cons) {
4498                        LispObject list1 = list3;
4499                        LispObject list2 = NIL;
4500                        do {
4501                            LispObject h = list3.cdr();
4502                            list3.setCdr(list2);
4503                            list2 = list3;
4504                            list3 = h;
4505                        } while (list3.cdr() instanceof Cons);
4506                        list.setCdr(list2);
4507                        list1.setCdr(list3);
4508                    }
4509                    LispObject h = list.car();
4510                    list.setCar(list3.car());
4511                    list3.setCar(h);
4512                    list3.setCdr(obj);
4513                } else if (list3 == NIL) {
4514                    list.setCdr(obj);
4515                } else
4516                    type_error(list3, Symbol.LIST);
4517                return list;
4518            } else if (list == NIL)
4519                return obj;
4520            else
4521                return type_error(list, Symbol.LIST);
4522        }
4523    };
4524
4525    // ### reverse
4526    private static final Primitive REVERSE = new pf_reverse();
4527    private static final class pf_reverse extends Primitive {
4528        pf_reverse() {
4529            super("%reverse", PACKAGE_SYS, false, "sequence");
4530        }
4531
4532        @Override
4533        public LispObject execute(LispObject arg) {
4534            return arg.reverse();
4535        }
4536    };
4537
4538    // ### delete-eq item sequence => result-sequence
4539    private static final Primitive DELETE_EQ = new pf_delete_eq();
4540    private static final class pf_delete_eq extends Primitive {
4541        pf_delete_eq() {
4542            super("delete-eq", PACKAGE_SYS, true, "item sequence");
4543        }
4544
4545        @Override
4546        public LispObject execute(LispObject item, LispObject sequence)
4547
4548        {
4549            if (sequence instanceof AbstractVector)
4550                return ((AbstractVector)sequence).deleteEq(item);
4551            else
4552                return LIST_DELETE_EQ.execute(item, sequence);
4553        }
4554    };
4555
4556    // ### delete-eql item seqluence => result-seqluence
4557    private static final Primitive DELETE_EQL = new pf_delete_eql();
4558    private static final class pf_delete_eql extends Primitive {
4559        pf_delete_eql() {
4560            super("delete-eql", PACKAGE_SYS, true, "item sequence");
4561        }
4562
4563        @Override
4564        public LispObject execute(LispObject item, LispObject sequence)
4565
4566        {
4567            if (sequence instanceof AbstractVector)
4568                return ((AbstractVector)sequence).deleteEql(item);
4569            else
4570                return LIST_DELETE_EQL.execute(item, sequence);
4571        }
4572    };
4573
4574    // ### list-delete-eq item list => result-list
4575    static final Primitive LIST_DELETE_EQ = new pf_list_delete_eq();
4576    private static final class pf_list_delete_eq extends Primitive {
4577        pf_list_delete_eq() {
4578            super("list-delete-eq", PACKAGE_SYS, true, "item list");
4579        }
4580
4581        @Override
4582        public LispObject execute(LispObject item, LispObject list)
4583
4584        {
4585            if (list instanceof Cons) {
4586                LispObject tail = list;
4587                LispObject splice = list;
4588                while (tail instanceof Cons) {
4589                    LispObject car = tail.car();
4590                    if (car == item) {
4591                        if (tail.cdr() != NIL) {
4592                            LispObject temp = tail;
4593                            tail.setCar(temp.cadr());
4594                            tail.setCdr(temp.cddr());
4595                        } else {
4596                            // Last item.
4597                            if (tail == list)
4598                                return NIL;
4599                            splice.setCdr(NIL);
4600                            return list;
4601                        }
4602                    } else {
4603                        splice = tail;
4604                        tail = tail.cdr();
4605                    }
4606                }
4607                if (tail == NIL)
4608                    return list;
4609                else
4610                    return type_error(tail, Symbol.LIST);
4611            } else if (list == NIL)
4612                return list;
4613            else
4614                return type_error(list, Symbol.LIST);
4615        }
4616    };
4617
4618    // ### list-delete-eql item list => result-list
4619    static final Primitive LIST_DELETE_EQL = new pf_list_delete_eql();
4620    private static final class pf_list_delete_eql extends Primitive {
4621        pf_list_delete_eql() {
4622            super("list-delete-eql", PACKAGE_SYS, true, "item list");
4623        }
4624
4625        @Override
4626        public LispObject execute(LispObject item, LispObject list)
4627
4628        {
4629            if (list instanceof Cons) {
4630                LispObject tail = list;
4631                LispObject splice = list;
4632                while (tail instanceof Cons) {
4633                    LispObject car = tail.car();
4634                    if (car.eql(item)) {
4635                        if (tail.cdr() != NIL) {
4636                            LispObject temp = tail;
4637                            tail.setCar(temp.cadr());
4638                            tail.setCdr(temp.cddr());
4639                        } else {
4640                            // Last item.
4641                            if (tail == list)
4642                                return NIL;
4643                            splice.setCdr(NIL);
4644                            return list;
4645                        }
4646                    } else {
4647                        splice = tail;
4648                        tail = tail.cdr();
4649                    }
4650                }
4651                if (tail == NIL)
4652                    return list;
4653                else
4654                    return type_error(tail, Symbol.LIST);
4655            } else if (list == NIL)
4656                return list;
4657            else
4658                return type_error(list, Symbol.LIST);
4659        }
4660    };
4661
4662    // ### vector-delete-eq item vector => result-vector
4663    private static final Primitive VECTOR_DELETE_EQ = new pf_vector_delete_eq();
4664    private static final class pf_vector_delete_eq extends Primitive {
4665        pf_vector_delete_eq() {
4666            super("vector-delete-eq", PACKAGE_SYS, true, "item vector");
4667        }
4668
4669        @Override
4670        public LispObject execute(LispObject item, LispObject vector)
4671
4672        {
4673            checkVector(vector).deleteEq(item);
4674            return vector;
4675        }
4676    };
4677
4678    // ### vector-delete-eql item vector => result-vector
4679    private static final Primitive VECTOR_DELETE_EQL = new pf_vector_delete_eql();
4680    private static final class pf_vector_delete_eql extends Primitive {
4681        pf_vector_delete_eql() {
4682            super("vector-delete-eql", PACKAGE_SYS, true, "item vector");
4683        }
4684
4685        @Override
4686        public LispObject execute(LispObject item, LispObject vector)
4687
4688        {
4689            checkVector(vector).deleteEql(item);
4690            return vector;
4691        }
4692    };
4693
4694    // ### %set-elt
4695    // %setelt sequence index newval => newval
4696    private static final Primitive _SET_ELT = new pf__set_elt();
4697    private static final class pf__set_elt extends Primitive {
4698        pf__set_elt() {
4699            super("%set-elt", PACKAGE_SYS, false);
4700        }
4701
4702        @Override
4703        public LispObject execute(LispObject first, LispObject second,
4704                                  LispObject third)
4705
4706        {
4707            if (first instanceof AbstractVector) {
4708                ((AbstractVector)first).aset(Fixnum.getValue(second), third);
4709                return third;
4710            }
4711            if (first instanceof Cons) {
4712                int index = Fixnum.getValue(second);
4713                if (index < 0)
4714                    error(new TypeError());
4715                LispObject list = first;
4716                int i = 0;
4717                while (true) {
4718                    if (i == index) {
4719                        list.setCar(third);
4720                        return third;
4721                    }
4722                    list = list.cdr();
4723                    if (list == NIL)
4724                        error(new TypeError());
4725                    ++i;
4726                }
4727            }
4728            return type_error(first, Symbol.SEQUENCE);
4729        }
4730    };
4731
4732    // ### %make-list
4733    private static final Primitive _MAKE_LIST = new pf__make_list();
4734    private static final class pf__make_list extends Primitive {
4735        pf__make_list() {
4736            super("%make-list", PACKAGE_SYS, true);
4737        }
4738
4739        @Override
4740        public LispObject execute(LispObject first, LispObject second)
4741
4742        {
4743            int size = Fixnum.getValue(first);
4744            if (size < 0)
4745                return type_error(first, list(Symbol.INTEGER, Fixnum.ZERO,
4746                                              Symbol.MOST_POSITIVE_FIXNUM.getSymbolValue()));
4747            LispObject result = NIL;
4748            for (int i = size; i-- > 0;)
4749                result = new Cons(second, result);
4750            return result;
4751        }
4752    };
4753
4754    // ### %member item list key test test-not => tail
4755    private static final Primitive _MEMBER = new pf__member();
4756    private static final class pf__member extends Primitive {
4757        pf__member() {
4758            super("%member", PACKAGE_SYS, true);
4759        }
4760
4761        @Override
4762        public LispObject execute(LispObject item, LispObject list,
4763                                  LispObject key, LispObject test,
4764                                  LispObject testNot)
4765
4766        {
4767            LispObject tail = checkList(list);
4768            if (test != NIL && testNot != NIL)
4769                error(new LispError("MEMBER: test and test-not both supplied"));
4770            if (testNot == NIL) {
4771                if (test == NIL || test == Symbol.EQL)
4772                    test = EQL;
4773            }
4774            if (key == NIL) {
4775                if (test == EQL) {
4776                    while (tail instanceof Cons) {
4777                        if (item.eql(((Cons)tail).car))
4778                            return tail;
4779                        tail = ((Cons)tail).cdr;
4780                    }
4781                } else if (test != NIL) {
4782                    while (tail instanceof Cons) {
4783                        LispObject candidate = ((Cons)tail).car;
4784                        if (test.execute(item, candidate) != NIL)
4785                            return tail;
4786                        tail = ((Cons)tail).cdr;
4787                    }
4788                } else {
4789                    // test == NIL
4790                    while (tail instanceof Cons) {
4791                        LispObject candidate = ((Cons)tail).car;
4792                        if (testNot.execute(item, candidate) == NIL)
4793                            return tail;
4794                        tail = ((Cons)tail).cdr;
4795                    }
4796                }
4797            } else {
4798                // key != NIL
4799                while (tail instanceof Cons) {
4800                    LispObject candidate = key.execute(((Cons)tail).car);
4801                    if (test != NIL) {
4802                        if (test.execute(item, candidate) != NIL)
4803                            return tail;
4804                    } else {
4805                        if (testNot.execute(item, candidate) == NIL)
4806                            return tail;
4807                    }
4808                    tail = ((Cons)tail).cdr;
4809                }
4810            }
4811            if (tail != NIL)
4812                type_error(tail, Symbol.LIST);
4813            return NIL;
4814        }
4815    };
4816
4817    // ### funcall-key function-or-nil element
4818    private static final Primitive FUNCALL_KEY = new pf_funcall_key();
4819    private static final class pf_funcall_key extends Primitive {
4820        pf_funcall_key() {
4821            super("funcall-key", PACKAGE_SYS, false);
4822        }
4823
4824        @Override
4825        public LispObject execute(LispObject first, LispObject second)
4826
4827        {
4828            if (first != NIL)
4829                return LispThread.currentThread().execute(first, second);
4830            return second;
4831        }
4832    };
4833
4834    // ### coerce-to-function
4835    private static final Primitive COERCE_TO_FUNCTION = new pf_coerce_to_function();
4836    private static final class pf_coerce_to_function extends Primitive {
4837        pf_coerce_to_function() {
4838            super("coerce-to-function", PACKAGE_SYS, true);
4839        }
4840
4841        @Override
4842        public LispObject execute(LispObject arg) {
4843            return coerceToFunction(arg);
4844        }
4845    };
4846
4847    // ### make-closure lambda-form environment => closure
4848    private static final Primitive MAKE_CLOSURE = new pf_make_closure();
4849    private static final class pf_make_closure extends Primitive {
4850        pf_make_closure() {
4851            super("make-closure", PACKAGE_SYS, true);
4852        }
4853
4854        @Override
4855        public LispObject execute(LispObject first, LispObject second)
4856
4857        {
4858            if (first instanceof Cons && ((Cons)first).car == Symbol.LAMBDA) {
4859                final Environment env;
4860                if (second == NIL)
4861                    env = new Environment();
4862                else
4863                    env = checkEnvironment(second);
4864                return new Closure(first, env);
4865            }
4866            return error(new TypeError("The argument to MAKE-CLOSURE is not a lambda form."));
4867        }
4868    };
4869
4870    // ### streamp
4871    private static final Primitive STREAMP = new pf_streamp();
4872    private static final class pf_streamp extends Primitive {
4873        pf_streamp() {
4874            super(Symbol.STREAMP, "object");
4875        }
4876
4877        @Override
4878        public LispObject execute(LispObject arg) {
4879            return arg instanceof Stream ? T : NIL;
4880        }
4881    };
4882
4883    // ### integerp
4884    private static final Primitive INTEGERP = new pf_integerp();
4885    private static final class pf_integerp extends Primitive {
4886        pf_integerp() {
4887            super(Symbol.INTEGERP, "object");
4888        }
4889
4890        @Override
4891        public LispObject execute(LispObject arg) {
4892            return arg.INTEGERP();
4893        }
4894    };
4895
4896    // ### evenp
4897    private static final Primitive EVENP = new pf_evenp();
4898    private static final class pf_evenp extends Primitive {
4899        pf_evenp() {
4900            super(Symbol.EVENP, "integer");
4901        }
4902
4903        @Override
4904        public LispObject execute(LispObject arg) {
4905            return arg.EVENP();
4906        }
4907    };
4908
4909    // ### oddp
4910    private static final Primitive ODDP = new pf_oddp();
4911    private static final class pf_oddp extends Primitive {
4912        pf_oddp() {
4913            super(Symbol.ODDP, "integer");
4914        }
4915
4916        @Override
4917        public LispObject execute(LispObject arg) {
4918            return arg.ODDP();
4919        }
4920    };
4921
4922    // ### numberp
4923    private static final Primitive NUMBERP = new pf_numberp();
4924    private static final class pf_numberp extends Primitive {
4925        pf_numberp() {
4926            super(Symbol.NUMBERP, "object");
4927        }
4928
4929        @Override
4930        public LispObject execute(LispObject arg) {
4931            return arg.NUMBERP();
4932        }
4933    };
4934
4935    // ### realp
4936    private static final Primitive REALP = new pf_realp();
4937    private static final class pf_realp extends Primitive {
4938        pf_realp() {
4939            super(Symbol.REALP, "object");
4940        }
4941
4942        @Override
4943        public LispObject execute(LispObject arg) {
4944            return arg.REALP();
4945        }
4946    };
4947
4948    // ### rationalp
4949    private static final Primitive RATIONALP = new pf_rationalp();
4950    private static final class pf_rationalp extends Primitive {
4951        pf_rationalp() {
4952            super(Symbol.RATIONALP,"object");
4953        }
4954
4955        @Override
4956        public LispObject execute(LispObject arg) {
4957            return arg.RATIONALP();
4958        }
4959    };
4960
4961    // ### complex
4962    private static final Primitive COMPLEX = new pf_complex();
4963    private static final class pf_complex extends Primitive {
4964        pf_complex() {
4965            super(Symbol.COMPLEX, "realpart &optional imagpart");
4966        }
4967
4968        @Override
4969        public LispObject execute(LispObject arg) {
4970            if (arg instanceof SingleFloat)
4971                return Complex.getInstance(arg, SingleFloat.ZERO);
4972            if (arg instanceof DoubleFloat)
4973                return Complex.getInstance(arg, DoubleFloat.ZERO);
4974            if (arg.realp())
4975                return arg;
4976            return type_error(arg, Symbol.REAL);
4977        }
4978        @Override
4979        public LispObject execute(LispObject first, LispObject second)
4980
4981        {
4982            return Complex.getInstance(first, second);
4983        }
4984    };
4985
4986    // ### complexp
4987    private static final Primitive COMPLEXP = new pf_complexp();
4988    private static final class pf_complexp extends Primitive {
4989        pf_complexp() {
4990            super(Symbol.COMPLEXP, "object");
4991        }
4992
4993        @Override
4994        public LispObject execute(LispObject arg) {
4995            return arg.COMPLEXP();
4996        }
4997    };
4998
4999    // ### numerator
5000    private static final Primitive NUMERATOR = new pf_numerator();
5001    private static final class pf_numerator extends Primitive {
5002        pf_numerator() {
5003            super(Symbol.NUMERATOR, "rational");
5004        }
5005
5006        @Override
5007        public LispObject execute(LispObject arg) {
5008            return arg.NUMERATOR();
5009        }
5010    };
5011
5012    // ### denominator
5013    private static final Primitive DENOMINATOR = new pf_denominator();
5014    private static final class pf_denominator extends Primitive {
5015        pf_denominator() {
5016            super(Symbol.DENOMINATOR, "rational");
5017        }
5018
5019        @Override
5020        public LispObject execute(LispObject arg) {
5021            return arg.DENOMINATOR();
5022        }
5023    };
5024
5025    // ### realpart
5026    private static final Primitive REALPART = new pf_realpart();
5027    private static final class pf_realpart extends Primitive {
5028        pf_realpart() {
5029            super(Symbol.REALPART, "number");
5030        }
5031
5032        @Override
5033        public LispObject execute(LispObject arg) {
5034            if (arg instanceof Complex)
5035                return ((Complex)arg).getRealPart();
5036            if (arg.numberp())
5037                return arg;
5038            return type_error(arg, Symbol.NUMBER);
5039        }
5040    };
5041
5042    // ### imagpart
5043    private static final Primitive IMAGPART = new pf_imagpart();
5044    private static final class pf_imagpart extends Primitive {
5045        pf_imagpart() {
5046            super(Symbol.IMAGPART, "number");
5047        }
5048
5049        @Override
5050        public LispObject execute(LispObject arg) {
5051            if (arg instanceof Complex)
5052                return ((Complex)arg).getImaginaryPart();
5053            return arg.multiplyBy(Fixnum.ZERO);
5054        }
5055    };
5056
5057    // ### integer-length
5058    private static final Primitive INTEGER_LENGTH = new pf_integer_length();
5059    private static final class pf_integer_length extends Primitive {
5060        pf_integer_length() {
5061            super(Symbol.INTEGER_LENGTH, "integer");
5062        }
5063
5064        @Override
5065        public LispObject execute(LispObject arg) {
5066            if (arg instanceof Fixnum) {
5067                int n = ((Fixnum)arg).value;
5068                if (n < 0)
5069                    n = ~n;
5070                int count = 0;
5071                while (n > 0) {
5072                    n = n >>> 1;
5073                    ++count;
5074                }
5075                return Fixnum.getInstance(count);
5076            }
5077            if (arg instanceof Bignum)
5078                return Fixnum.getInstance(((Bignum)arg).value.bitLength());
5079            return type_error(arg, Symbol.INTEGER);
5080        }
5081    };
5082
5083    // ### gcd-2
5084    private static final Primitive GCD_2 = new pf_gcd_2();
5085    private static final class pf_gcd_2 extends Primitive {
5086        pf_gcd_2() {
5087            super("gcd-2", PACKAGE_SYS, false);
5088        }
5089
5090        @Override
5091        public LispObject execute(LispObject first, LispObject second)
5092
5093        {
5094            BigInteger n1, n2;
5095            if (first instanceof Fixnum)
5096                n1 = BigInteger.valueOf(((Fixnum)first).value);
5097            else if (first instanceof Bignum)
5098                n1 = ((Bignum)first).value;
5099            else
5100                return type_error(first, Symbol.INTEGER);
5101            if (second instanceof Fixnum)
5102                n2 = BigInteger.valueOf(((Fixnum)second).value);
5103            else if (second instanceof Bignum)
5104                n2 = ((Bignum)second).value;
5105            else
5106                return type_error(second, Symbol.INTEGER);
5107            return number(n1.gcd(n2));
5108        }
5109    };
5110
5111    // ### identity-hash-code
5112    private static final Primitive IDENTITY_HASH_CODE = new pf_identity_hash_code();
5113    private static final class pf_identity_hash_code extends Primitive {
5114        pf_identity_hash_code() {
5115            super("identity-hash-code", PACKAGE_SYS, true);
5116        }
5117
5118        @Override
5119        public LispObject execute(LispObject arg) {
5120            return Fixnum.getInstance(System.identityHashCode(arg));
5121        }
5122    };
5123
5124    // ### simple-vector-search pattern vector => position
5125    // Searches vector for pattern.
5126    private static final Primitive SIMPLE_VECTOR_SEARCH = new pf_simple_vector_search();
5127    private static final class pf_simple_vector_search extends Primitive {
5128        pf_simple_vector_search() {
5129            super("simple-vector-search", PACKAGE_SYS, false);
5130        }
5131
5132        @Override
5133        public LispObject execute(LispObject first, LispObject second)
5134
5135        {
5136            AbstractVector v = checkVector(second);
5137            if (first.length() == 0)
5138                return Fixnum.ZERO;
5139            final int patternLength = first.length();
5140            final int limit = v.length() - patternLength;
5141            if (first instanceof AbstractVector) {
5142                AbstractVector pattern = (AbstractVector) first;
5143                LispObject element = pattern.AREF(0);
5144                for (int i = 0; i <= limit; i++) {
5145                    if (v.AREF(i).eql(element)) {
5146                        // Found match for first element of pattern.
5147                        boolean match = true;
5148                        // We've already checked the first element.
5149                        int j = i + 1;
5150                        for (int k = 1; k < patternLength; k++) {
5151                            if (v.AREF(j).eql(pattern.AREF(k))) {
5152                                ++j;
5153                            } else {
5154                                match = false;
5155                                break;
5156                            }
5157                        }
5158                        if (match)
5159                            return Fixnum.getInstance(i);
5160                    }
5161                }
5162            } else {
5163                // Pattern is a list.
5164                LispObject element = first.car();
5165                for (int i = 0; i <= limit; i++) {
5166                    if (v.AREF(i).eql(element)) {
5167                        // Found match for first element of pattern.
5168                        boolean match = true;
5169                        // We've already checked the first element.
5170                        int j = i + 1;
5171                        for (LispObject rest = first.cdr(); rest != NIL; rest = rest.cdr()) {
5172                            if (v.AREF(j).eql(rest.car())) {
5173                                ++j;
5174                            } else {
5175                                match = false;
5176                                break;
5177                            }
5178                        }
5179                        if (match)
5180                            return Fixnum.getInstance(i);
5181                    }
5182                }
5183            }
5184            return NIL;
5185        }
5186    };
5187
5188    // ### uptime
5189    private static final Primitive UPTIME = new pf_uptime();
5190    private static final class pf_uptime extends Primitive {
5191        pf_uptime() {
5192            super("uptime", PACKAGE_EXT, true);
5193        }
5194
5195        @Override
5196        public LispObject execute() {
5197            return number(System.currentTimeMillis() - Main.startTimeMillis);
5198        }
5199    };
5200
5201    // ### built-in-function-p
5202    private static final Primitive BUILT_IN_FUNCTION_P = new pf_built_in_function_p();
5203    private static final class pf_built_in_function_p extends Primitive {
5204        pf_built_in_function_p() {
5205            super("built-in-function-p", PACKAGE_SYS, true);
5206        }
5207
5208        @Override
5209        public LispObject execute(LispObject arg) {
5210            return checkSymbol(arg).isBuiltInFunction() ? T : NIL;
5211        }
5212    };
5213
5214    // ### inspected-parts
5215    private static final Primitive INSPECTED_PARTS = new pf_inspected_parts();
5216    private static final class pf_inspected_parts extends Primitive {
5217        pf_inspected_parts() {
5218            super("inspected-parts", PACKAGE_SYS, true);
5219        }
5220
5221        @Override
5222        public LispObject execute(LispObject arg) {
5223            return arg.getParts();
5224        }
5225    };
5226
5227    // ### inspected-description
5228    private static final Primitive INSPECTED_DESCRIPTION = new pf_inspected_description();
5229    private static final class pf_inspected_description extends Primitive {
5230        pf_inspected_description() {
5231            super("inspected-description", PACKAGE_SYS, false);
5232        }
5233
5234        @Override
5235        public LispObject execute(LispObject arg) {
5236            return arg.getDescription();
5237        }
5238    };
5239
5240    // ### symbol-name
5241    public static final Primitive SYMBOL_NAME = new pf_symbol_name();
5242    private static final class pf_symbol_name extends Primitive {
5243        pf_symbol_name() {
5244            super(Symbol.SYMBOL_NAME, "symbol");
5245        }
5246
5247        @Override
5248        public LispObject execute(LispObject arg) {
5249            return checkSymbol(arg).name;
5250        }
5251    };
5252
5253    // ### symbol-package
5254    public static final Primitive SYMBOL_PACKAGE = new pf_symbol_package();
5255    private static final class pf_symbol_package extends Primitive {
5256        pf_symbol_package() {
5257            super(Symbol.SYMBOL_PACKAGE, "symbol");
5258        }
5259
5260        @Override
5261        public LispObject execute(LispObject arg) {
5262            return checkSymbol(arg).getPackage();
5263        }
5264    };
5265
5266    // ### symbol-function
5267    public static final Primitive SYMBOL_FUNCTION = new pf_symbol_function();
5268    private static final class pf_symbol_function extends Primitive {
5269        pf_symbol_function() {
5270            super(Symbol.SYMBOL_FUNCTION, "symbol");
5271        }
5272
5273        @Override
5274        public LispObject execute(LispObject arg) {
5275            LispObject function = checkSymbol(arg).getSymbolFunction();
5276            if (function != null)
5277                return function;
5278            return error(new UndefinedFunction(arg));
5279
5280        }
5281    };
5282
5283    // ### %set-symbol-function
5284    public static final Primitive _SET_SYMBOL_FUNCTION = new pf__set_symbol_function();
5285    private static final class pf__set_symbol_function extends Primitive {
5286        pf__set_symbol_function() {
5287            super("%set-symbol-function", PACKAGE_SYS, false, "symbol function");
5288        }
5289
5290        @Override
5291        public LispObject execute(LispObject first, LispObject second)
5292
5293        {
5294            checkSymbol(first).setSymbolFunction(second);
5295            return second;
5296        }
5297    };
5298
5299    // ### symbol-plist
5300    public static final Primitive SYMBOL_PLIST = new pf_symbol_plist();
5301    private static final class pf_symbol_plist extends Primitive {
5302        pf_symbol_plist() {
5303            super(Symbol.SYMBOL_PLIST, "symbol");
5304        }
5305
5306        @Override
5307        public LispObject execute(LispObject arg) {
5308            return checkSymbol(arg).getPropertyList();
5309        }
5310    };
5311
5312    // ### keywordp
5313    public static final Primitive KEYWORDP = new pf_keywordp();
5314    private static final class pf_keywordp extends Primitive {
5315        pf_keywordp() {
5316            super(Symbol.KEYWORDP, "object");
5317        }
5318
5319        @Override
5320        public LispObject execute(LispObject arg) {
5321            if (arg instanceof Symbol) {
5322                if (checkSymbol(arg).getPackage() == PACKAGE_KEYWORD)
5323                    return T;
5324            }
5325            return NIL;
5326        }
5327    };
5328
5329    // ### make-symbol
5330    public static final Primitive MAKE_SYMBOL = new pf_make_symbol();
5331    private static final class pf_make_symbol extends Primitive {
5332        pf_make_symbol() {
5333            super(Symbol.MAKE_SYMBOL, "name");
5334        }
5335
5336        @Override
5337        public LispObject execute(LispObject arg) {
5338            if (arg instanceof SimpleString)
5339                return new Symbol((SimpleString)arg);
5340            // Not a simple string.
5341            if (arg instanceof AbstractString)
5342                return new Symbol(arg.getStringValue());
5343            return type_error(arg, Symbol.STRING);
5344        }
5345    };
5346
5347    // ### makunbound
5348    public static final Primitive MAKUNBOUND = new pf_makunbound();
5349    private static final class pf_makunbound extends Primitive {
5350        pf_makunbound() {
5351            super(Symbol.MAKUNBOUND, "symbol");
5352        }
5353
5354        @Override
5355        public LispObject execute(LispObject arg) {
5356            checkSymbol(arg).setSymbolValue(null);
5357            return arg;
5358        }
5359    };
5360
5361    // ### %class-name
5362    private static final Primitive _CLASS_NAME = new pf__class_name();
5363    private static final class pf__class_name extends Primitive {
5364        pf__class_name() {
5365            super("%class-name", PACKAGE_SYS, true, "class");
5366        }
5367
5368        @Override
5369        public LispObject execute(LispObject arg) {
5370            if (arg instanceof LispClass)
5371                return ((LispClass)arg).getName();
5372
5373            return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symName);
5374        }
5375    };
5376
5377    // ### %set-class-name
5378    private static final Primitive _SET_CLASS_NAME = new pf__set_class_name();
5379    private static final class pf__set_class_name extends Primitive {
5380        pf__set_class_name() {
5381            super("%set-class-name", PACKAGE_SYS, true);
5382        }
5383
5384        @Override
5385        public LispObject execute(LispObject first, LispObject second)
5386
5387        {
5388            if (second instanceof LispClass)
5389                ((LispClass)second).setName(checkSymbol(first));
5390            else
5391                ((StandardObject)second).setInstanceSlotValue(StandardClass.symName,
5392                                                           checkSymbol(first));
5393            return first;
5394        }
5395    };
5396
5397    // ### class-layout
5398    private static final Primitive CLASS_LAYOUT = new pf__class_layout();
5399    private static final class pf__class_layout extends Primitive {
5400        pf__class_layout() {
5401            super("%class-layout", PACKAGE_SYS, true, "class");
5402        }
5403
5404        @Override
5405        public LispObject execute(LispObject arg) {
5406            Layout layout;
5407            if (arg instanceof LispClass)
5408              layout = ((LispClass)arg).getClassLayout();
5409            else
5410              layout = (Layout)((StandardObject)arg).getInstanceSlotValue(StandardClass.symLayout);
5411
5412            return layout != null ? layout : NIL;
5413        }
5414    };
5415
5416    // ### %set-class-layout
5417    private static final Primitive _SET_CLASS_LAYOUT = new pf__set_class_layout();
5418    private static final class pf__set_class_layout extends Primitive {
5419        pf__set_class_layout() {
5420            super("%set-class-layout", PACKAGE_SYS, true, "class layout");
5421        }
5422
5423        @Override
5424        public LispObject execute(LispObject first, LispObject second)
5425
5426        {
5427            if (first == NIL || first instanceof Layout) {
5428                if (second instanceof LispClass)
5429                  ((LispClass)second).setClassLayout(first);
5430                else
5431                  ((StandardObject)second).setInstanceSlotValue(StandardClass.symLayout, first);
5432                return first;
5433            }
5434            return type_error(first, Symbol.LAYOUT);
5435        }
5436    };
5437
5438    // ### %class-direct-superclasses
5439    private static final Primitive _CLASS_DIRECT_SUPERCLASSES = new pf__class_direct_superclasses();
5440    private static final class pf__class_direct_superclasses extends Primitive {
5441        pf__class_direct_superclasses() {
5442            super("%class-direct-superclasses", PACKAGE_SYS, true);
5443        }
5444
5445        @Override
5446        public LispObject execute(LispObject arg) {
5447            if (arg instanceof LispClass)
5448              return ((LispClass)arg).getDirectSuperclasses();
5449            else
5450              return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSuperclasses);
5451        }
5452    };
5453
5454    // ### %set-class-direct-superclasses
5455    private static final Primitive _SET_CLASS_DIRECT_SUPERCLASSES = new pf__set_class_direct_superclasses();
5456    private static final class pf__set_class_direct_superclasses extends Primitive {
5457        pf__set_class_direct_superclasses() {
5458            super("%set-class-direct-superclasses", PACKAGE_SYS, true);
5459        }
5460
5461        @Override
5462        public LispObject execute(LispObject first, LispObject second)
5463        {
5464            if (second instanceof LispClass)
5465              ((LispClass)second).setDirectSuperclasses(first);
5466            else
5467              ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectSuperclasses, first);
5468            return first;
5469        }
5470    };
5471
5472    // ### %class-direct-subclasses
5473    private static final Primitive _CLASS_DIRECT_SUBCLASSES = new pf__class_direct_subclasses();
5474    private static final class pf__class_direct_subclasses extends Primitive {
5475        pf__class_direct_subclasses() {
5476            super("%class-direct-subclasses", PACKAGE_SYS, true);
5477        }
5478
5479        @Override
5480        public LispObject execute(LispObject arg) {
5481            if (arg instanceof LispClass)
5482                return ((LispClass)arg).getDirectSubclasses();
5483            else
5484                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSubclasses);
5485        }
5486    };
5487
5488    // ### %set-class-direct-subclasses
5489    private static final Primitive _SET_CLASS_DIRECT_SUBCLASSES = new pf__set_class_direct_subclasses();
5490    private static final class pf__set_class_direct_subclasses extends Primitive {
5491        pf__set_class_direct_subclasses() {
5492            super("%set-class-direct-subclasses", PACKAGE_SYS, true,
5493                  "class direct-subclasses");
5494        }
5495
5496        @Override
5497        public LispObject execute(LispObject first, LispObject second)
5498        {
5499            if (second instanceof LispClass)
5500                ((LispClass)second).setDirectSubclasses(first);
5501            else
5502                ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectSubclasses, first);
5503            return first;
5504        }
5505    };
5506
5507    // ### %class-precedence-list
5508    private static final Primitive _CLASS_PRECEDENCE_LIST = new pf__class_precedence_list();
5509    private static final class pf__class_precedence_list extends Primitive {
5510        pf__class_precedence_list() {
5511            super("%class-precedence-list", PACKAGE_SYS, true);
5512        }
5513
5514        @Override
5515        public LispObject execute(LispObject arg) {
5516            if (arg instanceof LispClass)
5517                return ((LispClass)arg).getCPL();
5518            else
5519                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symPrecedenceList);
5520        }
5521    };
5522
5523    // ### %set-class-precedence-list
5524    private static final Primitive _SET_CLASS_PRECEDENCE_LIST = new pf__set_class_precedence_list();
5525    private static final class pf__set_class_precedence_list extends Primitive {
5526        pf__set_class_precedence_list() {
5527            super("%set-class-precedence-list", PACKAGE_SYS, true);
5528        }
5529
5530        @Override
5531        public LispObject execute(LispObject first, LispObject second)
5532        {
5533            if (second instanceof LispClass)
5534                ((LispClass)second).setCPL(first);
5535            else
5536                ((StandardObject)second).setInstanceSlotValue(StandardClass.symPrecedenceList, first);
5537            return first;
5538        }
5539    };
5540
5541    // ### %class-direct-methods
5542    private static final Primitive _CLASS_DIRECT_METHODS = new pf__class_direct_methods();
5543    private static final class pf__class_direct_methods extends Primitive {
5544        pf__class_direct_methods() {
5545            super("%class-direct-methods", PACKAGE_SYS, true);
5546        }
5547
5548        @Override
5549        public LispObject execute(LispObject arg)
5550        {
5551            if (arg instanceof LispClass)
5552                return ((LispClass)arg).getDirectMethods();
5553            else
5554                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectMethods);
5555        }
5556    };
5557
5558    // ### %set-class-direct-methods
5559    private static final Primitive _SET_CLASS_DIRECT_METHODS = new pf__set_class_direct_methods();
5560    private static final class pf__set_class_direct_methods extends Primitive {
5561        pf__set_class_direct_methods() {
5562            super("%set-class-direct-methods", PACKAGE_SYS, true);
5563        }
5564
5565        @Override
5566        public LispObject execute(LispObject first, LispObject second)
5567        {
5568            if (second instanceof LispClass)
5569                ((LispClass)second).setDirectMethods(first);
5570            else
5571                ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectMethods, first);
5572            return first;
5573        }
5574    };
5575
5576    // ### class-documentation
5577    private static final Primitive CLASS_DOCUMENTATION
5578        = new pf_class_documentation();
5579    private static final class pf_class_documentation extends Primitive {
5580        pf_class_documentation() {
5581            super("class-documentation", PACKAGE_MOP, true);
5582        }
5583
5584        @Override
5585        public LispObject execute(LispObject arg)
5586
5587        {
5588            if (arg instanceof LispClass)
5589                return ((LispClass)arg).getDocumentation();
5590            else
5591                return ((StandardObject)arg).getInstanceSlotValue(Symbol._DOCUMENTATION);
5592        }
5593    };
5594
5595    // ### %set-class-documentation
5596    private static final Primitive _SET_CLASS_DOCUMENTATION
5597        = new pf__set_class_documentation();
5598    private static final class pf__set_class_documentation extends Primitive {
5599        pf__set_class_documentation() {
5600            super("%set-class-documentation", PACKAGE_SYS, true);
5601        }
5602
5603        @Override
5604        public LispObject execute(LispObject first, LispObject second)
5605        {
5606            if (first instanceof LispClass)
5607                ((LispClass)first).setDocumentation(second);
5608            else
5609                ((StandardObject)first).setInstanceSlotValue(Symbol._DOCUMENTATION, second);
5610            return second;
5611        }
5612    };
5613
5614    // ### %class-finalized-p
5615    private static final Primitive _CLASS_FINALIZED_P = new pf__class_finalized_p();
5616    private static final class pf__class_finalized_p extends Primitive {
5617        pf__class_finalized_p() {
5618            super("%class-finalized-p", PACKAGE_SYS, true);
5619        }
5620
5621        @Override
5622        public LispObject execute(LispObject arg) {
5623            if (arg instanceof LispClass)
5624                return ((LispClass)arg).isFinalized() ? T : NIL;
5625            else
5626                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symFinalizedP);
5627        }
5628    };
5629
5630    // ### %set-class-finalized-p
5631    private static final Primitive _SET_CLASS_FINALIZED_P = new pf__set_class_finalized_p();
5632    private static final class pf__set_class_finalized_p extends Primitive {
5633        pf__set_class_finalized_p() {
5634            super("%set-class-finalized-p", PACKAGE_SYS, true);
5635        }
5636
5637        @Override
5638        public LispObject execute(LispObject first, LispObject second)
5639        {
5640            if (second instanceof LispClass)
5641                ((LispClass)second).setFinalized(first != NIL);
5642            else
5643                ((StandardObject)second).setInstanceSlotValue(StandardClass.symFinalizedP, first);
5644            return first;
5645        }
5646    };
5647
5648    // ### classp
5649    private static final Primitive CLASSP = new pf_classp();
5650    private static final class pf_classp extends Primitive {
5651        pf_classp() {
5652            super("classp", PACKAGE_EXT, true);
5653        }
5654
5655        @Override
5656        public LispObject execute(LispObject arg) {
5657            return (arg instanceof LispClass) ? T : arg.typep(Symbol.CLASS);
5658        }
5659    };
5660
5661    // ### char-to-utf8 char => octets
5662    private static final Primitive CHAR_TO_UTF8 = new pf_char_to_utf8();
5663    private static final class pf_char_to_utf8 extends Primitive {
5664        pf_char_to_utf8() {
5665            super("char-to-utf8", PACKAGE_EXT, true);
5666        }
5667
5668        @Override
5669        public LispObject execute(LispObject arg) {
5670            final LispCharacter c;
5671            c = checkCharacter( arg);
5672            char[] chars = new char[1];
5673            chars[0] = c.value;
5674            String s = new String(chars);
5675            final byte[] bytes;
5676            try {
5677                bytes = s.getBytes("UTF8");
5678            } catch (java.io.UnsupportedEncodingException e) {
5679                return error(new LispError("UTF8 is not a supported encoding."));
5680            }
5681            LispObject[] objects = new LispObject[bytes.length];
5682            for (int i = bytes.length; i-- > 0;) {
5683                int n = bytes[i];
5684                if (n < 0)
5685                    n += 256;
5686                objects[i] = Fixnum.getInstance(n);
5687            }
5688            return new SimpleVector(objects);
5689        }
5690    };
5691
5692    // ### %documentation
5693    private static final Primitive _DOCUMENTATION = new pf__documentation();
5694    private static final class pf__documentation extends Primitive {
5695        pf__documentation() {
5696            super("%documentation", PACKAGE_SYS, true,
5697                  "object doc-type");
5698        }
5699
5700        @Override
5701        public LispObject execute(LispObject object, LispObject docType)
5702
5703        {
5704            LispObject doc = object.getDocumentation(docType);
5705            if (doc == NIL) {
5706                if (docType == Symbol.FUNCTION && object instanceof Symbol) {
5707                    // Generic functions are handled at lisp-level, not here
5708                    LispObject function = object.getSymbolFunction();
5709                    if (function != null)
5710                        doc = function.getDocumentation(docType);
5711                }
5712            }
5713            return doc;
5714        }
5715    };
5716
5717    // ### %set-documentation
5718    private static final Primitive _SET_DOCUMENTATION = new pf__set_documentation();
5719    private static final class pf__set_documentation extends Primitive {
5720        pf__set_documentation() {
5721            super("%set-documentation", PACKAGE_SYS, true,
5722                  "object doc-type documentation");
5723        }
5724
5725        @Override
5726        public LispObject execute(LispObject object, LispObject docType,
5727                                  LispObject documentation)
5728
5729        {
5730            // Generic functions are handled at lisp-level, not here
5731            object.setDocumentation(docType, documentation);
5732            return documentation;
5733        }
5734    };
5735
5736    // ### %putf
5737    private static final Primitive _PUTF = new pf__putf();
5738    private static final class pf__putf extends Primitive {
5739        pf__putf() {
5740            super("%putf", PACKAGE_SYS, true,
5741                  "plist indicator new-value");
5742        }
5743
5744        @Override
5745        public LispObject execute(LispObject plist, LispObject indicator,
5746                                  LispObject newValue)
5747
5748        {
5749            return putf(plist, indicator, newValue);
5750        }
5751    };
5752
5753    // ### function-plist
5754    private static final Primitive FUNCTION_PLIST = new pf_function_plist();
5755    private static final class pf_function_plist extends Primitive {
5756        pf_function_plist() {
5757            super("function-plist", PACKAGE_SYS, true, "function");
5758        }
5759
5760        @Override
5761        public LispObject execute(LispObject arg) {
5762            return checkFunction(arg).getPropertyList();
5763        }
5764    };
5765
5766    // ### make-keyword
5767    private static final Primitive MAKE_KEYWORD = new pf_make_keyword();
5768    private static final class pf_make_keyword extends Primitive {
5769        pf_make_keyword() {
5770            super("make-keyword", PACKAGE_SYS, true, "symbol");
5771        }
5772
5773        @Override
5774        public LispObject execute(LispObject arg) {
5775            return PACKAGE_KEYWORD.intern(checkSymbol(arg).name);
5776        }
5777    };
5778
5779    // ### standard-object-p object => generalized-boolean
5780    private static final Primitive STANDARD_OBJECT_P = new pf_standard_object_p();
5781    private static final class pf_standard_object_p extends Primitive {
5782        pf_standard_object_p() {
5783            super("standard-object-p", PACKAGE_SYS, true, "object");
5784        }
5785
5786        @Override
5787        public LispObject execute(LispObject arg) {
5788            return arg instanceof StandardObject ? T : NIL;
5789        }
5790    };
5791
5792    // ### copy-tree
5793    private static final Primitive COPY_TREE = new pf_copy_tree();
5794    private static final class pf_copy_tree extends Primitive {
5795        pf_copy_tree() {
5796            super(Symbol.COPY_TREE, "object");
5797        }
5798
5799        @Override
5800        public LispObject execute(LispObject arg) {
5801            if (arg instanceof Cons) {
5802                Cons cons = (Cons) arg;
5803                return new Cons(execute(cons.car), execute(cons.cdr));
5804            } else
5805                return arg;
5806        }
5807    };
5808
5809    /* Added to ABCL because Maxima wants to be able to turn off
5810     * underflow conditions. However, the Hyperspec says we have to
5811     * signal them. So, we went for CLHS compliant with a switch for
5812     * Maxima.
5813     */
5814    // ### float-underflow-mode
5815    private static final Primitive FLOAT_UNDERFLOW_MODE
5816        = new pf_float_underflow_mode();
5817    private static final class pf_float_underflow_mode extends Primitive {
5818        pf_float_underflow_mode() {
5819            super(Symbol.FLOAT_UNDERFLOW_MODE, "&optional boolean");
5820        }
5821
5822        @Override
5823        public LispObject execute() {
5824            return Lisp.TRAP_UNDERFLOW ? T : NIL;
5825        }
5826
5827        @Override
5828        public LispObject execute(LispObject arg) {
5829            Lisp.TRAP_UNDERFLOW = (arg != NIL);
5830            return arg;
5831        }
5832    };
5833
5834    /* Implemented for symmetry with the underflow variant. */
5835    // ### float-overflow-mode
5836    private static final Primitive FLOAT_OVERFLOW_MODE
5837        = new pf_float_overflow_mode();
5838    private static final class pf_float_overflow_mode extends Primitive {
5839        pf_float_overflow_mode() {
5840            super(Symbol.FLOAT_OVERFLOW_MODE, "&optional boolean");
5841        }
5842
5843        @Override
5844        public LispObject execute() {
5845            return Lisp.TRAP_OVERFLOW ? T : NIL;
5846        }
5847
5848        @Override
5849        public LispObject execute(LispObject arg) {
5850            Lisp.TRAP_OVERFLOW = (arg != NIL);
5851            return arg;
5852        }
5853    };
5854
5855    // ### finalize
5856    private static final Primitive FINALIZE
5857        = new pf_finalize();
5858    private static final class pf_finalize extends Primitive {
5859        pf_finalize() {
5860            super("finalize", PACKAGE_EXT, true, "object function");
5861        }
5862
5863        @Override
5864        public LispObject execute(LispObject obj, final LispObject fun) {
5865            Finalizer.addFinalizer(obj, new Runnable() {
5866                @Override
5867                public void run() {
5868                    fun.execute();
5869                }
5870            });
5871            return obj;
5872        }
5873    };
5874
5875    // ### cancel-finalization
5876    private static final Primitive CANCEL_FINALIZATION
5877        = new pf_cancel_finalization();
5878    private static final class pf_cancel_finalization extends Primitive {
5879        pf_cancel_finalization() {
5880            super("cancel-finalization", PACKAGE_EXT, true, "object");
5881        }
5882
5883        @Override
5884        public LispObject execute(LispObject obj) {
5885            Finalizer.clearFinalizers(obj);
5886            return obj;
5887        }
5888    };
5889
5890    private static final Primitive GET_FASL_READTABLE
5891            = new pf_get_fasl_readtable();
5892    private static class pf_get_fasl_readtable extends Primitive {
5893        pf_get_fasl_readtable() {
5894            super("get-fasl-readtable", PACKAGE_SYS, false);
5895        }
5896       
5897        @Override
5898        public LispObject execute() {
5899            return FaslReadtable.getInstance();
5900        }
5901    }
5902   
5903    private static final Primitive _VECTOR_REPLACE
5904            = new pf_vector_replace();
5905    private static class pf_vector_replace extends Primitive {
5906        pf_vector_replace() {
5907            super("%vector-replace", PACKAGE_SYS, false);
5908        }
5909
5910        @Override
5911        public LispObject execute(LispObject target, LispObject source,
5912                                  LispObject targetStart, LispObject targetEnd,
5913                                  LispObject sourceStart, LispObject sourceEnd) {
5914          if (!(target instanceof AbstractVector))
5915            return type_error(target, Symbol.VECTOR);
5916          if (!(source instanceof AbstractVector))
5917            return type_error(source, Symbol.VECTOR);
5918          if (!(targetStart instanceof Fixnum))
5919            return type_error(targetStart, Symbol.FIXNUM);
5920          if (!(targetEnd instanceof Fixnum))
5921            return type_error(targetEnd, Symbol.FIXNUM);
5922          if (!(sourceStart instanceof Fixnum))
5923            return type_error(sourceStart, Symbol.FIXNUM);
5924          if (!(sourceEnd instanceof Fixnum))
5925            return type_error(sourceEnd, Symbol.FIXNUM);
5926
5927          int sStart = sourceStart.intValue();
5928          int sEnd   = sourceEnd.intValue();
5929          int tStart = targetStart.intValue();
5930          int tEnd   = targetEnd.intValue();
5931
5932          // TODO: Better error messages? These are user-facing.
5933          if (!(0 <= tStart && tStart <= tEnd && tEnd <= target.length()))
5934            error(new LispError("Bad target sequence bounds."));
5935          if (!(0 <= sStart && sStart <= sEnd && sEnd <= source.length()))
5936            error(new LispError("Bad source sequence bounds."));
5937
5938          // Clamp here so we don't have to repeat this in every method.
5939          sStart = Math.max(0, sStart);
5940          sEnd   = Math.min(sEnd, source.length());
5941          tStart = Math.max(0, tStart);
5942          tEnd   = Math.min(tEnd, target.length());
5943
5944          int nelts = Math.min(sEnd - sStart, tEnd - tStart);
5945
5946          return ((AbstractVector)target).replace(((AbstractVector)source), tStart, tStart + nelts, sStart, sStart + nelts);
5947        }
5948    }
5949}
Note: See TracBrowser for help on using the repository browser.