source: branches/1.1.x/src/org/armedbear/lisp/Primitives.java

Last change on this file was 14378, checked in by Mark Evenson, 12 years ago

Backport r14369 | mevenson | 2013-02-13 20:01:20 +0100 (Wed, 13 Feb 2013) | 7 lines

Implementation of autoloader for SETF generalized references.

Fixes #296. Fixes #266. Fixes #228.

For forms which set the symbol properties of SETF-EXPANDER or
SETF-FUNCTION to function definitions, places stub of type
AutoloadGeneralizedReference? to be resolved when first invoked.

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