source: branches/streams/abcl/src/org/armedbear/lisp/Primitives.java

Last change on this file was 14588, checked in by ehuelsmann, 11 years ago

Fix "COND clause should at least have a test form" bug reported by

Pascal Bourguingon.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 195.4 KB
Line 
1/*
2 * Primitives.java
3 *
4 * Copyright (C) 2002-2007 Peter Graves
5 * Copyright (C) 2011 Erik Huelsmann
6 * $Id: Primitives.java 14588 2013-11-24 21:00:55Z ehuelsmann $
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                    return program_error(symbol.getName() + " is a special operator and may not be redefined.");
1784                }
1785            } else if (!isValidSetfFunctionName(name))
1786                return type_error(name, FUNCTION_NAME);
1787            if (definition instanceof Function) {
1788                Symbol.FSET.execute(name, definition, NIL,
1789                                    ((Function)definition).getLambdaList());
1790                return name;
1791            }
1792            return type_error(definition, Symbol.FUNCTION);
1793        }
1794    };
1795
1796    // ### fdefinition-block-name
1797    private static final Primitive FDEFINITION_BLOCK_NAME = new pf_fdefinition_block_name();
1798    private static final class pf_fdefinition_block_name extends Primitive {
1799        pf_fdefinition_block_name() {
1800            super("fdefinition-block-name", PACKAGE_SYS, true, "function-name");
1801        }
1802
1803        @Override
1804        public LispObject execute(LispObject arg) {
1805            if (arg instanceof Symbol)
1806                return arg;
1807            if (isValidSetfFunctionName(arg))
1808                return arg.cadr();
1809            return type_error(arg, FUNCTION_NAME);
1810        }
1811    };
1812
1813    // ### macro-function
1814    private static final Primitive MACRO_FUNCTION = new pf_macro_function();
1815    private static final class pf_macro_function extends Primitive {
1816        pf_macro_function() {
1817            super(Symbol.MACRO_FUNCTION, "symbol &optional environment");
1818        }
1819
1820        @Override
1821        public LispObject execute(LispObject arg) {
1822            LispObject obj = arg.getSymbolFunction();
1823            if (obj instanceof AutoloadMacro) {
1824                ((AutoloadMacro)obj).load();
1825                obj = arg.getSymbolFunction();
1826            }
1827            if (obj instanceof MacroObject)
1828                return ((MacroObject)obj).expander;
1829            if (obj instanceof SpecialOperator) {
1830                obj = get(arg, Symbol.MACROEXPAND_MACRO, NIL);
1831                if (obj instanceof AutoloadMacro) {
1832                    ((AutoloadMacro)obj).load();
1833                    obj = get(arg, Symbol.MACROEXPAND_MACRO, NIL);
1834                }
1835                if (obj instanceof MacroObject)
1836                    return ((MacroObject)obj).expander;
1837            }
1838            return NIL;
1839        }
1840        @Override
1841        public LispObject execute(LispObject first, LispObject second)
1842
1843        {
1844            LispObject obj;
1845            if (second != NIL) {
1846                Environment env = checkEnvironment(second);
1847                obj = env.lookupFunction(first);
1848            } else
1849                obj = first.getSymbolFunction();
1850            if (obj instanceof AutoloadMacro) {
1851                ((AutoloadMacro)obj).load();
1852                obj = first.getSymbolFunction();
1853            }
1854            if (obj instanceof MacroObject)
1855                return ((MacroObject)obj).expander;
1856            if (obj instanceof SpecialOperator) {
1857                obj = get(first, Symbol.MACROEXPAND_MACRO, NIL);
1858                if (obj instanceof AutoloadMacro) {
1859                    ((AutoloadMacro)obj).load();
1860                    obj = get(first, Symbol.MACROEXPAND_MACRO, NIL);
1861                }
1862                if (obj instanceof MacroObject)
1863                    return ((MacroObject)obj).expander;
1864            }
1865            return NIL;
1866        }
1867    };
1868
1869    // ### defmacro
1870    private static final SpecialOperator DEFMACRO = new sf_defmacro();
1871    private static final class sf_defmacro extends SpecialOperator {
1872        sf_defmacro() {
1873            super(Symbol.DEFMACRO);
1874        }
1875
1876        @Override
1877        public LispObject execute(LispObject args, Environment env)
1878
1879        {
1880            Symbol symbol = checkSymbol(args.car());
1881            LispObject expander = MAKE_MACRO_EXPANDER.execute(args);
1882            Closure expansionFunction = new Closure(expander, env);
1883            MacroObject macroObject =
1884                new MacroObject(symbol, expansionFunction);
1885            if (symbol.getSymbolFunction() instanceof SpecialOperator)
1886                put(symbol, Symbol.MACROEXPAND_MACRO, macroObject);
1887            else
1888                symbol.setSymbolFunction(macroObject);
1889            macroObject.setLambdaList(args.cadr());
1890            LispThread.currentThread()._values = null;
1891            return symbol;
1892        }
1893    };
1894
1895    // ### make-macro
1896    private static final Primitive MAKE_MACRO = new pf_make_macro();
1897    private static final class pf_make_macro extends Primitive {
1898        pf_make_macro() {
1899            super("make-macro", PACKAGE_SYS, true, "name expansion-function");
1900        }
1901
1902        @Override
1903        public LispObject execute(LispObject first, LispObject second)
1904
1905        {
1906            return new MacroObject(first, second);
1907        }
1908    };
1909
1910    // ### macro-function-p
1911    private static final Primitive MACRO_FUNCTION_P = new pf_macro_function_p();
1912    private static final class pf_macro_function_p extends Primitive {
1913        pf_macro_function_p() {
1914            super("macro-function-p", PACKAGE_SYS, true, "value");
1915        }
1916
1917        @Override
1918        public LispObject execute(LispObject arg) {
1919            return (arg instanceof MacroObject) ? T : NIL;
1920        }
1921    };
1922
1923
1924    // ### make-symbol-macro
1925    private static final Primitive MAKE_SYMBOL_MACRO = new pf_make_symbol_macro();
1926    private static final class pf_make_symbol_macro extends Primitive {
1927        pf_make_symbol_macro() {
1928            super("make-symbol-macro", PACKAGE_SYS, true, "expansion");
1929        }
1930
1931        @Override
1932        public LispObject execute(LispObject arg) {
1933            return new SymbolMacro(arg);
1934        }
1935    };
1936
1937    // ### %set-symbol-macro
1938    private static final Primitive SET_SYMBOL_MACRO = new pf_set_symbol_macro();
1939    private static final class pf_set_symbol_macro extends Primitive {
1940        pf_set_symbol_macro() {
1941            super("%set-symbol-macro", PACKAGE_SYS, false, "symbol symbol-macro");
1942        }
1943
1944        @Override
1945        public LispObject execute(LispObject sym, LispObject symbolMacro) {
1946            checkSymbol(sym).setSymbolMacro((SymbolMacro) symbolMacro);
1947            return symbolMacro;
1948        }
1949    };
1950
1951    // ### symbol-macro-p
1952    private static final Primitive SYMBOL_MACRO_P = new pf_symbol_macro_p();
1953    private static final class pf_symbol_macro_p extends Primitive {
1954        pf_symbol_macro_p() {
1955            super("symbol-macro-p", PACKAGE_SYS, true, "value");
1956        }
1957
1958        @Override
1959        public LispObject execute(LispObject arg) {
1960            return (arg instanceof SymbolMacro) ? T : NIL;
1961        }
1962    };
1963
1964    // ### %defparameter
1965    private static final Primitive _DEFPARAMETER = new pf__defparameter();
1966    private static final class pf__defparameter extends Primitive {
1967        pf__defparameter() {
1968            super("%defparameter", PACKAGE_SYS, false);
1969        }
1970
1971        @Override
1972        public LispObject execute(LispObject first, LispObject second,
1973                                  LispObject third)
1974
1975        {
1976            final Symbol symbol;
1977            symbol = checkSymbol(first);
1978            if (third instanceof AbstractString)
1979                symbol.setDocumentation(Symbol.VARIABLE, third);
1980            else if (third != NIL)
1981                type_error(third, Symbol.STRING);
1982            symbol.initializeSpecial(second);
1983            return symbol;
1984        }
1985    };
1986
1987    // ### %defvar
1988    private static final Primitive _DEFVAR = new pf__defvar();
1989    private static final class pf__defvar extends Primitive {
1990        pf__defvar() {
1991            super("%defvar", PACKAGE_SYS, false);
1992        }
1993
1994        @Override
1995        public LispObject execute(LispObject arg) {
1996            final Symbol symbol;
1997            symbol = checkSymbol(arg);
1998            symbol.setSpecial(true);
1999            return symbol;
2000        }
2001        @Override
2002        public LispObject execute(LispObject first, LispObject second)
2003
2004        {
2005            final Symbol symbol;
2006            symbol = checkSymbol(first);
2007            symbol.initializeSpecial(second);
2008            return symbol;
2009        }
2010    };
2011
2012    // ### %defconstant name initial-value documentation => name
2013    private static final Primitive _DEFCONSTANT = new pf__defconstant();
2014    private static final class pf__defconstant extends Primitive {
2015        pf__defconstant() {
2016            super("%defconstant", PACKAGE_SYS, false);
2017        }
2018
2019        @Override
2020        public LispObject execute(LispObject first, LispObject second,
2021                                  LispObject third)
2022
2023        {
2024            final Symbol symbol;
2025            symbol = checkSymbol(first);
2026            if (third != NIL) {
2027                if (third instanceof AbstractString)
2028                    symbol.setDocumentation(Symbol.VARIABLE, third);
2029                else
2030                    return type_error(third, Symbol.STRING);
2031            }
2032            symbol.initializeConstant(second);
2033            return symbol;
2034        }
2035    };
2036
2037    // ### cond
2038    private static final SpecialOperator COND = new sf_cond();
2039    private static final class sf_cond extends SpecialOperator {
2040        sf_cond() {
2041            super(Symbol.COND, "&rest clauses");
2042        }
2043
2044        @Override
2045        public LispObject execute(LispObject args, Environment env)
2046        {
2047            final LispThread thread = LispThread.currentThread();
2048            LispObject result = NIL;
2049            while (args != NIL) {
2050                LispObject clause = args.car();
2051                if (! (clause instanceof Cons))
2052                  return error(new ProgramError("COND clause is not a non-empty list: "
2053                                                + clause.princToString()));
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                sb.append(".");
2314                program_error(sb.toString());
2315            }
2316            for (int i = 0; i < rank; i++) {
2317                LispObject arg = args[i+1];
2318                if (arg instanceof Fixnum) {
2319                    int subscript = ((Fixnum)arg).value;
2320                    if (subscript < 0 || subscript >= array.getDimension(i))
2321                        return NIL;
2322                } else if (arg instanceof Bignum)
2323                    return NIL;
2324                else
2325                    type_error(arg, Symbol.INTEGER);
2326            }
2327            return T;
2328        }
2329    };
2330
2331    // ### %array-row-major-index array subscripts => index
2332    private static final Primitive _ARRAY_ROW_MAJOR_INDEX = new pf__array_row_major_index();
2333    private static final class pf__array_row_major_index extends Primitive {
2334        pf__array_row_major_index() {
2335            super("%array-row-major-index", PACKAGE_SYS, false);
2336        }
2337
2338        @Override
2339        public LispObject execute(LispObject first, LispObject second)
2340
2341        {
2342            final AbstractArray array;
2343            array = checkArray(first);
2344            LispObject[] subscripts = second.copyToArray();
2345            return number(array.getRowMajorIndex(subscripts));
2346        }
2347    };
2348
2349    // ### aref array &rest subscripts => element
2350    private static final Primitive AREF = new pf_aref();
2351    private static final class pf_aref extends Primitive {
2352        pf_aref() {
2353            super(Symbol.AREF, "array &rest subscripts");
2354        }
2355
2356        @Override
2357        public LispObject execute() {
2358            return error(new WrongNumberOfArgumentsException(this, 1, -1));
2359        }
2360        @Override
2361        public LispObject execute(LispObject arg) {
2362            final AbstractArray array;
2363            array = checkArray( arg);
2364            if (array.getRank() == 0)
2365                return array.AREF(0);
2366            StringBuilder sb =
2367                new StringBuilder("Wrong number of subscripts (0) for array of rank ");
2368            sb.append(array.getRank());
2369            sb.append('.');
2370            return program_error(sb.toString());
2371        }
2372        @Override
2373        public LispObject execute(LispObject first, LispObject second)
2374
2375        {
2376            return first.AREF(second);
2377        }
2378        @Override
2379        public LispObject execute(LispObject first, LispObject second,
2380                                  LispObject third)
2381
2382        {
2383            return checkArray(first).get(new int[] {Fixnum.getValue(second),Fixnum.getValue(third)} );
2384        }
2385        @Override
2386        public LispObject execute(LispObject[] args) {
2387            final AbstractArray array = checkArray(args[0]);
2388            final int[] subs = new int[args.length - 1];
2389            for (int i = subs.length; i-- > 0;) {
2390                subs[i] = Fixnum.getValue(args[i+1]);
2391            }
2392            return array.get(subs);
2393        }
2394    };
2395
2396    // ### aset array subscripts new-element => new-element
2397    private static final Primitive ASET = new pf_aset();
2398    private static final class pf_aset extends Primitive {
2399        pf_aset() {
2400            super("aset", PACKAGE_SYS, true,
2401                  "array subscripts new-element");
2402        }
2403
2404        @Override
2405        public LispObject execute(LispObject first, LispObject second)
2406
2407        {
2408            // Rank zero array.
2409            final ZeroRankArray array;
2410            if (first instanceof ZeroRankArray) {
2411                array = (ZeroRankArray) first;
2412            } else {
2413                return error(new TypeError("The value " +
2414                                           first.princToString() +
2415                                           " is not an array of rank 0."));
2416            }
2417            array.aset(0, second);
2418            return second;
2419        }
2420        @Override
2421        public LispObject execute(LispObject first, LispObject second,
2422                                  LispObject third)
2423
2424        {
2425            first.aset(second, third);
2426            return third;
2427        }
2428        @Override
2429        public LispObject execute(LispObject[] args) {
2430            final AbstractArray array = checkArray(args[0]);
2431            final int nsubs = args.length - 2;
2432            final int[] subs = new int[nsubs];
2433            for (int i = nsubs; i-- > 0;)
2434                subs[i] = Fixnum.getValue(args[i+1]);
2435            final LispObject newValue = args[args.length - 1];
2436            array.set(subs, newValue);
2437            return newValue;
2438        }
2439    };
2440
2441    // ### row-major-aref array index => element
2442    private static final Primitive ROW_MAJOR_AREF = new pf_row_major_aref();
2443    private static final class pf_row_major_aref extends Primitive {
2444        pf_row_major_aref() {
2445            super(Symbol.ROW_MAJOR_AREF, "array index");
2446        }
2447
2448        @Override
2449        public LispObject execute(LispObject first, LispObject second)
2450
2451        {
2452            return checkArray(first).AREF(Fixnum.getValue(second));
2453        }
2454    };
2455
2456    // ### vector
2457    private static final Primitive VECTOR = new pf_vector();
2458    private static final class pf_vector extends Primitive {
2459        pf_vector() {
2460            super(Symbol.VECTOR, "&rest objects");
2461        }
2462
2463        @Override
2464        public LispObject execute(LispObject[] args) {
2465            return new SimpleVector(args);
2466        }
2467    };
2468
2469    // ### fill-pointer
2470    private static final Primitive FILL_POINTER = new pf_fill_pointer();
2471    private static final class pf_fill_pointer extends Primitive {
2472        pf_fill_pointer() {
2473            super(Symbol.FILL_POINTER, "vector");
2474        }
2475
2476        @Override
2477        public LispObject execute(LispObject arg)
2478
2479        {
2480            if (arg instanceof AbstractArray) {
2481                AbstractArray aa = (AbstractArray)arg;
2482                if (aa.hasFillPointer())
2483                    return Fixnum.getInstance(aa.getFillPointer());
2484            }
2485            return type_error(arg, list(Symbol.AND, Symbol.VECTOR,
2486                                        list(Symbol.SATISFIES,
2487                                             Symbol.ARRAY_HAS_FILL_POINTER_P)));
2488        }
2489    };
2490
2491    // ### %set-fill-pointer vector new-fill-pointer
2492    private static final Primitive _SET_FILL_POINTER = new pf__set_fill_pointer();
2493    private static final class pf__set_fill_pointer extends Primitive {
2494        pf__set_fill_pointer() {
2495            super("%set-fill-pointer", PACKAGE_SYS, true);
2496        }
2497
2498        @Override
2499        public LispObject execute(LispObject first, LispObject second)
2500
2501        {
2502
2503            if (first instanceof AbstractVector) {
2504                AbstractVector v = (AbstractVector) first;
2505                if (v.hasFillPointer())
2506                    v.setFillPointer(second);
2507                else
2508                    v.noFillPointer();
2509                return second;
2510            }
2511
2512            return type_error(first, list(Symbol.AND, Symbol.VECTOR,
2513                                          list(Symbol.SATISFIES,
2514                                               Symbol.ARRAY_HAS_FILL_POINTER_P)));
2515        }
2516    };
2517
2518    // ### vector-push new-element vector => index-of-new-element
2519    private static final Primitive VECTOR_PUSH = new pf_vector_push();
2520    private static final class pf_vector_push extends Primitive {
2521        pf_vector_push() {
2522            super(Symbol.VECTOR_PUSH, "new-element vector");
2523        }
2524
2525        @Override
2526        public LispObject execute(LispObject first, LispObject second)
2527
2528        {
2529            final AbstractVector v = checkVector(second);
2530            int fillPointer = v.getFillPointer();
2531            if (fillPointer < 0)
2532                v.noFillPointer();
2533            if (fillPointer >= v.capacity())
2534                return NIL;
2535            v.aset(fillPointer, first);
2536            v.setFillPointer(fillPointer + 1);
2537            return Fixnum.getInstance(fillPointer);
2538        }
2539    };
2540
2541    // ### vector-push-extend new-element vector &optional extension
2542    // => index-of-new-element
2543    private static final Primitive VECTOR_PUSH_EXTEND = new pf_vector_push_extend();
2544    private static final class pf_vector_push_extend extends Primitive {
2545        pf_vector_push_extend() {
2546            super(Symbol.VECTOR_PUSH_EXTEND,
2547                  "new-element vector &optional extension");
2548        }
2549
2550        @Override
2551        public LispObject execute(LispObject first, LispObject second)
2552
2553        {
2554            return second.VECTOR_PUSH_EXTEND(first);
2555        }
2556
2557        @Override
2558        public LispObject execute(LispObject first, LispObject second,
2559                                  LispObject third)
2560
2561        {
2562            return second.VECTOR_PUSH_EXTEND(first, third);
2563        }
2564    };
2565
2566    // ### vector-pop vector => element
2567    private static final Primitive VECTOR_POP = new pf_vector_pop();
2568    private static final class pf_vector_pop extends Primitive {
2569        pf_vector_pop() {
2570            super(Symbol.VECTOR_POP, "vector");
2571        }
2572
2573        @Override
2574        public LispObject execute(LispObject arg) {
2575            final AbstractVector v = checkVector( arg);
2576            int fillPointer = v.getFillPointer();
2577            if (fillPointer < 0)
2578                v.noFillPointer();
2579            if (fillPointer == 0)
2580                error(new LispError("nothing left to pop"));
2581            int newFillPointer = v.checkIndex(fillPointer - 1);
2582            LispObject element = v.AREF(newFillPointer);
2583            v.setFillPointer(newFillPointer);
2584            return element;
2585        }
2586    };
2587
2588    // ### type-of
2589    private static final Primitive TYPE_OF = new pf_type_of();
2590    private static final class pf_type_of extends Primitive {
2591        pf_type_of() {
2592            super(Symbol.TYPE_OF, "object");
2593        }
2594
2595        @Override
2596        public LispObject execute(LispObject arg) {
2597            return arg.typeOf();
2598        }
2599    };
2600
2601    // ### class-of
2602    private static final Primitive CLASS_OF = new pf_class_of();
2603    private static final class pf_class_of extends Primitive {
2604        pf_class_of() {
2605            super(Symbol.CLASS_OF, "object");
2606        }
2607
2608        @Override
2609        public LispObject execute(LispObject arg) {
2610            return arg.classOf();
2611        }
2612    };
2613
2614    // ### simple-typep
2615    private static final Primitive SIMPLE_TYPEP = new pf_simple_typep();
2616    private static final class pf_simple_typep extends Primitive {
2617        pf_simple_typep() {
2618            super("simple-typep", PACKAGE_SYS, true);
2619        }
2620
2621        @Override
2622        public LispObject execute(LispObject first, LispObject second)
2623
2624        {
2625            return first.typep(second);
2626        }
2627    };
2628
2629    // ### function-lambda-expression function =>
2630    // lambda-expression, closure-p, name
2631    private static final Primitive FUNCTION_LAMBDA_EXPRESSION = new pf_function_lambda_expression();
2632    private static final class pf_function_lambda_expression extends Primitive {
2633        pf_function_lambda_expression() {
2634            super(Symbol.FUNCTION_LAMBDA_EXPRESSION, "function");
2635        }
2636
2637        @Override
2638        public LispObject execute(LispObject arg) {
2639            final LispObject value1, value2, value3;
2640            if (arg instanceof CompiledClosure) {
2641                value1 = NIL;
2642                value2 = T;
2643                LispObject name = ((CompiledClosure)arg).getLambdaName();
2644                value3 = name != null ? name : NIL;
2645            } else if (arg instanceof Closure) {
2646                Closure closure = (Closure) arg;
2647                LispObject expr = closure.getBody();
2648                expr = new Cons(closure.getLambdaList(), expr);
2649                expr = new Cons(Symbol.LAMBDA, expr);
2650                value1 = expr;
2651                Environment env = closure.getEnvironment();
2652                if (env == null || env.isEmpty())
2653                    value2 = NIL;
2654                else
2655                    value2 = env; // Return environment as closure-p.
2656                LispObject name = ((Closure)arg).getLambdaName();
2657                value3 = name != null ? name : NIL;
2658            } else if (arg instanceof Function) {
2659                value1 = NIL;
2660                value2 = T;
2661                value3 = ((Function)arg).getLambdaName();
2662            } else if (arg.typep(Symbol.GENERIC_FUNCTION) != NIL) {
2663                value1 = NIL;
2664                value2 = T;
2665                value3 = Symbol.GENERIC_FUNCTION_NAME.execute(arg);
2666            } else if (arg instanceof FuncallableStandardObject) {
2667              return this.execute(((FuncallableStandardObject)arg).function);
2668            } else {
2669              return type_error(arg, Symbol.FUNCTION);
2670            }
2671            return LispThread.currentThread().setValues(value1, value2, value3);
2672        }
2673    };
2674
2675    // ### funcall
2676    // This needs to be public for LispAPI.java.
2677    public static final Primitive FUNCALL = new pf_funcall();
2678    private static final class pf_funcall extends Primitive {
2679        pf_funcall() {
2680            super(Symbol.FUNCALL, "function &rest args");
2681        }
2682
2683        @Override
2684        public LispObject execute() {
2685            return error(new WrongNumberOfArgumentsException(this, 1, -1));
2686        }
2687        @Override
2688        public LispObject execute(LispObject arg) {
2689            return LispThread.currentThread().execute(arg);
2690        }
2691        @Override
2692        public LispObject execute(LispObject first, LispObject second)
2693
2694        {
2695            return LispThread.currentThread().execute(first, second);
2696        }
2697        @Override
2698        public LispObject execute(LispObject first, LispObject second,
2699                                  LispObject third)
2700
2701        {
2702            return LispThread.currentThread().execute(first, second, third);
2703        }
2704        @Override
2705        public LispObject execute(LispObject first, LispObject second,
2706                                  LispObject third, LispObject fourth)
2707
2708        {
2709            return LispThread.currentThread().execute(first, second, third,
2710                    fourth);
2711        }
2712        @Override
2713        public LispObject execute(LispObject first, LispObject second,
2714                                  LispObject third, LispObject fourth,
2715                                  LispObject fifth)
2716
2717        {
2718            return LispThread.currentThread().execute(first, second, third,
2719                    fourth, fifth);
2720        }
2721        @Override
2722        public LispObject execute(LispObject first, LispObject second,
2723                                  LispObject third, LispObject fourth,
2724                                  LispObject fifth, LispObject sixth)
2725
2726        {
2727            return LispThread.currentThread().execute(first, second, third,
2728                    fourth, fifth, sixth);
2729        }
2730        @Override
2731        public LispObject execute(LispObject first, LispObject second,
2732                                  LispObject third, LispObject fourth,
2733                                  LispObject fifth, LispObject sixth,
2734                                  LispObject seventh)
2735
2736        {
2737            return LispThread.currentThread().execute(first, second, third,
2738                    fourth, fifth, sixth,
2739                    seventh);
2740        }
2741        @Override
2742        public LispObject execute(LispObject first, LispObject second,
2743                                  LispObject third, LispObject fourth,
2744                                  LispObject fifth, LispObject sixth,
2745                                  LispObject seventh, LispObject eigth)
2746
2747        {
2748            return LispThread.currentThread().execute(first, second, third,
2749                    fourth, fifth, sixth,
2750                    seventh, eigth);
2751        }
2752        @Override
2753        public LispObject execute(LispObject[] args) {
2754            final int length = args.length - 1; // Number of arguments.
2755            if (length == 8) {
2756                return LispThread.currentThread().execute(args[0], args[1],
2757                        args[2], args[3],
2758                        args[4], args[5],
2759                        args[6], args[7],
2760                        args[8]);
2761            } else {
2762                LispObject[] newArgs = new LispObject[length];
2763                System.arraycopy(args, 1, newArgs, 0, length);
2764                return LispThread.currentThread().execute(args[0], newArgs);
2765            }
2766        }
2767    };
2768
2769    // ### apply
2770    public static final Primitive APPLY = new pf_apply();
2771    private static final class pf_apply extends Primitive {
2772        pf_apply() {
2773            super(Symbol.APPLY, "function &rest args");
2774        }
2775
2776        @Override
2777        public LispObject execute() {
2778            return error(new WrongNumberOfArgumentsException(this, 2, -1));
2779        }
2780        @Override
2781        public LispObject execute(LispObject arg) {
2782            return error(new WrongNumberOfArgumentsException(this, 2, -1));
2783        }
2784        @Override
2785        public LispObject execute(LispObject fun, LispObject args)
2786
2787        {
2788            final LispThread thread = LispThread.currentThread();
2789            final int length = args.length();
2790            switch (length) {
2791            case 0:
2792                return thread.execute(fun);
2793            case 1:
2794                return thread.execute(fun, ((Cons)args).car);
2795            case 2: {
2796                Cons cons = (Cons) args;
2797                return thread.execute(fun, cons.car, ((Cons)cons.cdr).car);
2798            }
2799            case 3:
2800                return thread.execute(fun, args.car(), args.cadr(),
2801                                      args.cdr().cdr().car());
2802            default: {
2803                final LispObject[] funArgs = new LispObject[length];
2804                int j = 0;
2805                while (args != NIL) {
2806                    funArgs[j++] = args.car();
2807                    args = args.cdr();
2808                }
2809                return funcall(fun, funArgs, thread);
2810            }
2811            }
2812        }
2813        @Override
2814        public LispObject execute(LispObject first, LispObject second,
2815                                  LispObject third)
2816
2817        {
2818            if (third.listp()) {
2819                final int numFunArgs = 1 + third.length();
2820                final LispObject[] funArgs = new LispObject[numFunArgs];
2821                funArgs[0] = second;
2822                int j = 1;
2823                while (third != NIL) {
2824                    funArgs[j++] = third.car();
2825                    third = third.cdr();
2826                }
2827                return funcall(first, funArgs, LispThread.currentThread());
2828            }
2829            return type_error(third, Symbol.LIST);
2830        }
2831        @Override
2832        public LispObject execute(final LispObject[] args) {
2833            final int numArgs = args.length;
2834            LispObject spread = args[numArgs - 1];
2835            if (spread.listp()) {
2836                final int numFunArgs = numArgs - 2 + spread.length();
2837                final LispObject[] funArgs = new LispObject[numFunArgs];
2838                int j = 0;
2839                for (int i = 1; i < numArgs - 1; i++)
2840                    funArgs[j++] = args[i];
2841                while (spread != NIL) {
2842                    funArgs[j++] = spread.car();
2843                    spread = spread.cdr();
2844                }
2845                return funcall(args[0], funArgs, LispThread.currentThread());
2846            }
2847            return type_error(spread, Symbol.LIST);
2848        }
2849    };
2850
2851    // ### mapcar
2852    private static final Primitive MAPCAR = new pf_mapcar();
2853    private static final class pf_mapcar extends Primitive {
2854        pf_mapcar() {
2855            super(Symbol.MAPCAR, "function &rest lists");
2856        }
2857
2858        @Override
2859        public LispObject execute(LispObject fun, LispObject list)
2860
2861        {
2862            final LispThread thread = LispThread.currentThread();
2863            LispObject result = NIL;
2864            Cons splice = null;
2865            while (list != NIL) {
2866                Cons cons;
2867                if (list instanceof Cons)
2868                    cons = (Cons) list;
2869                else
2870                    return type_error(list, Symbol.LIST);
2871                LispObject obj = thread.execute(fun, cons.car);
2872                if (splice == null) {
2873                    splice = new Cons(obj, result);
2874                    result = splice;
2875                } else {
2876                    Cons c = new Cons(obj);
2877                    splice.cdr = c;
2878                    splice = c;
2879                }
2880                list = cons.cdr;
2881            }
2882            thread._values = null;
2883            return result;
2884        }
2885        @Override
2886        public LispObject execute(LispObject fun, LispObject list1,
2887                                  LispObject list2)
2888
2889        {
2890            final LispThread thread = LispThread.currentThread();
2891            LispObject result = NIL;
2892            Cons splice = null;
2893            while (list1 != NIL && list2 != NIL) {
2894                LispObject obj =
2895                    thread.execute(fun, list1.car(), list2.car());
2896                if (splice == null) {
2897                    splice = new Cons(obj, result);
2898                    result = splice;
2899                } else {
2900                    Cons cons = new Cons(obj);
2901                    splice.cdr = cons;
2902                    splice = cons;
2903                }
2904                list1 = list1.cdr();
2905                list2 = list2.cdr();
2906            }
2907            thread._values = null;
2908            return result;
2909        }
2910        @Override
2911        public LispObject execute(final LispObject[] args)
2912
2913        {
2914            final int numArgs = args.length;
2915            if (numArgs < 2)
2916                return error(new WrongNumberOfArgumentsException(this, 2, -1));
2917            int commonLength = -1;
2918            for (int i = 1; i < numArgs; i++) {
2919                if (!args[i].listp())
2920                    type_error(args[i], Symbol.LIST);
2921                int len = args[i].length();
2922                if (commonLength < 0)
2923                    commonLength = len;
2924                else if (commonLength > len)
2925                    commonLength = len;
2926            }
2927            final LispThread thread = LispThread.currentThread();
2928            LispObject[] results = new LispObject[commonLength];
2929            final int numFunArgs = numArgs - 1;
2930            final LispObject[] funArgs = new LispObject[numFunArgs];
2931            for (int i = 0; i < commonLength; i++) {
2932                for (int j = 0; j < numFunArgs; j++)
2933                    funArgs[j] = args[j+1].car();
2934                results[i] = funcall(args[0], funArgs, thread);
2935                for (int j = 1; j < numArgs; j++)
2936                    args[j] = args[j].cdr();
2937            }
2938            thread._values = null;
2939            LispObject result = NIL;
2940            for (int i = commonLength; i-- > 0;)
2941                result = new Cons(results[i], result);
2942            return result;
2943        }
2944    };
2945
2946    // ### mapc
2947    private static final Primitive MAPC = new pf_mapc();
2948    private static final class pf_mapc extends Primitive {
2949        pf_mapc() {
2950            super(Symbol.MAPC, "function &rest lists");
2951        }
2952
2953        @Override
2954        public LispObject execute(LispObject fun, LispObject list)
2955
2956        {
2957            final LispThread thread = LispThread.currentThread();
2958            LispObject result = list;
2959            while (list != NIL) {
2960                Cons cons;
2961                if (list instanceof Cons)
2962                    cons = (Cons) list;
2963                else
2964                    return type_error(list, Symbol.LIST);
2965                thread.execute(fun, cons.car);
2966                list = cons.cdr;
2967            }
2968            thread._values = null;
2969            return result;
2970        }
2971        @Override
2972        public LispObject execute(LispObject fun, LispObject list1,
2973                                  LispObject list2)
2974
2975        {
2976            final LispThread thread = LispThread.currentThread();
2977            LispObject result = list1;
2978            while (list1 != NIL && list2 != NIL) {
2979                thread.execute(fun, list1.car(), list2.car());
2980                list1 = ((Cons)list1).cdr;
2981                list2 = ((Cons)list2).cdr;
2982            }
2983            thread._values = null;
2984            return result;
2985        }
2986        @Override
2987        public LispObject execute(final LispObject[] args)
2988
2989        {
2990            final int numArgs = args.length;
2991            if (numArgs < 2)
2992                return error(new WrongNumberOfArgumentsException(this, 2, -1));
2993            int commonLength = -1;
2994            for (int i = 1; i < numArgs; i++) {
2995                if (!args[i].listp())
2996                    type_error(args[i], Symbol.LIST);
2997                int len = args[i].length();
2998                if (commonLength < 0)
2999                    commonLength = len;
3000                else if (commonLength > len)
3001                    commonLength = len;
3002            }
3003            final LispThread thread = LispThread.currentThread();
3004            LispObject result = args[1];
3005            final int numFunArgs = numArgs - 1;
3006            final LispObject[] funArgs = new LispObject[numFunArgs];
3007            for (int i = 0; i < commonLength; i++) {
3008                for (int j = 0; j < numFunArgs; j++)
3009                    funArgs[j] = args[j+1].car();
3010                funcall(args[0], funArgs, thread);
3011                for (int j = 1; j < numArgs; j++)
3012                    args[j] = args[j].cdr();
3013            }
3014            thread._values = null;
3015            return result;
3016        }
3017    };
3018
3019    // ### macroexpand
3020    private static final Primitive MACROEXPAND = new pf_macroexpand();
3021    private static final class pf_macroexpand extends Primitive {
3022        pf_macroexpand() {
3023            super(Symbol.MACROEXPAND, "form &optional env");
3024        }
3025
3026        @Override
3027        public LispObject execute(LispObject form) {
3028            return macroexpand(form,
3029                               new Environment(),
3030                               LispThread.currentThread());
3031        }
3032        @Override
3033        public LispObject execute(LispObject form, LispObject env)
3034
3035        {
3036            return macroexpand(form,
3037                               env != NIL ? checkEnvironment(env) : new Environment(),
3038                               LispThread.currentThread());
3039        }
3040    };
3041
3042    // ### macroexpand-1
3043    private static final Primitive MACROEXPAND_1 = new pf_macroexpand_1();
3044    private static final class pf_macroexpand_1 extends Primitive {
3045        pf_macroexpand_1() {
3046            super(Symbol.MACROEXPAND_1, "form &optional env");
3047        }
3048
3049        @Override
3050        public LispObject execute(LispObject form) {
3051            return macroexpand_1(form,
3052                                 new Environment(),
3053                                 LispThread.currentThread());
3054        }
3055        @Override
3056        public LispObject execute(LispObject form, LispObject env)
3057
3058        {
3059            return macroexpand_1(form,
3060                                 env != NIL ? checkEnvironment(env) : new Environment(),
3061                                 LispThread.currentThread());
3062        }
3063    };
3064
3065    // ### gensym
3066    public static final Primitive GENSYM = new pf_gensym();
3067    private static final class pf_gensym extends Primitive {
3068        pf_gensym() {
3069            super(Symbol.GENSYM, "&optional x");
3070        }
3071
3072        @Override
3073        public LispObject execute() {
3074            return gensym("G", LispThread.currentThread());
3075        }
3076        @Override
3077        public LispObject execute(LispObject arg) {
3078            if (arg instanceof Fixnum) {
3079                int n = ((Fixnum)arg).value;
3080                if (n >= 0) {
3081                    StringBuilder sb = new StringBuilder("G");
3082                    sb.append(n); // Decimal representation.
3083                    return new Symbol(new SimpleString(sb));
3084                }
3085            } else if (arg instanceof Bignum) {
3086                BigInteger n = ((Bignum)arg).value;
3087                if (n.signum() >= 0) {
3088                    StringBuilder sb = new StringBuilder("G");
3089                    sb.append(n.toString()); // Decimal representation.
3090                    return new Symbol(new SimpleString(sb));
3091                }
3092            } else if (arg instanceof AbstractString)
3093                return gensym(arg.getStringValue(), LispThread.currentThread());
3094            return type_error(arg,
3095                              list(Symbol.OR,
3096                                   Symbol.STRING,
3097                                   Symbol.UNSIGNED_BYTE));
3098        }
3099    };
3100
3101    // ### string
3102    private static final Primitive STRING = new pf_string();
3103    private static final class pf_string extends Primitive {
3104        pf_string() {
3105            super(Symbol.STRING, "x");
3106        }
3107
3108        @Override
3109        public LispObject execute(LispObject arg) {
3110            return arg.STRING();
3111        }
3112    };
3113
3114    // ### intern string &optional package => symbol, status
3115    // STATUS is one of :INHERITED, :EXTERNAL, :INTERNAL or NIL.
3116    // "It is implementation-dependent whether the string that becomes the new
3117    // symbol's name is the given string or a copy of it."
3118    private static final Primitive INTERN = new pf_intern();
3119    private static final class pf_intern extends Primitive {
3120        pf_intern() {
3121            super(Symbol.INTERN, "string &optional package");
3122        }
3123
3124        @Override
3125        public LispObject execute(LispObject arg) {
3126            final SimpleString s;
3127            if (arg instanceof SimpleString)
3128                s = (SimpleString) arg;
3129            else
3130                s = new SimpleString(arg.getStringValue());
3131            final LispThread thread = LispThread.currentThread();
3132            Package pkg = (Package) Symbol._PACKAGE_.symbolValue(thread);
3133            return pkg.intern(s, thread);
3134        }
3135        @Override
3136        public LispObject execute(LispObject first, LispObject second)
3137
3138        {
3139            final SimpleString s;
3140            if (first instanceof SimpleString)
3141                s = (SimpleString) first;
3142            else
3143                s = new SimpleString(first.getStringValue());
3144            Package pkg = coerceToPackage(second);
3145            return pkg.intern(s, LispThread.currentThread());
3146        }
3147    };
3148
3149    // ### unintern
3150    // unintern symbol &optional package => generalized-boolean
3151    private static final Primitive UNINTERN = new pf_unintern();
3152    private static final class pf_unintern extends Primitive {
3153        pf_unintern() {
3154            super(Symbol.UNINTERN, "symbol &optional package");
3155        }
3156
3157        @Override
3158        public LispObject execute(LispObject[] args) {
3159            if (args.length == 0 || args.length > 2)
3160                return error(new WrongNumberOfArgumentsException(this, 1, 2));
3161            Symbol symbol = checkSymbol(args[0]);
3162            Package pkg;
3163            if (args.length == 2)
3164                pkg = coerceToPackage(args[1]);
3165            else
3166                pkg = getCurrentPackage();
3167            return pkg.unintern(symbol);
3168        }
3169    };
3170
3171    // ### find-package
3172    private static final Primitive FIND_PACKAGE = new pf_find_package();
3173    private static final class pf_find_package extends Primitive {
3174        pf_find_package() {
3175            super(Symbol.FIND_PACKAGE, "name");
3176        }
3177
3178        @Override
3179        public LispObject execute(LispObject arg) {
3180            if (arg instanceof Package)
3181                return arg;
3182            if (arg instanceof AbstractString) {
3183                Package pkg =
3184                  getCurrentPackage().findPackage(arg.getStringValue());
3185                return pkg != null ? pkg : NIL;
3186            }
3187            if (arg instanceof Symbol) {
3188                Package pkg = getCurrentPackage().findPackage(checkSymbol(arg).getName());
3189                return pkg != null ? pkg : NIL;
3190            }
3191            if (arg instanceof LispCharacter) {
3192                String packageName =
3193                    String.valueOf(new char[] {((LispCharacter)arg).getValue()});
3194                Package pkg = getCurrentPackage().findPackage(packageName);
3195                return pkg != null ? pkg : NIL;
3196            }
3197            return NIL;
3198        }
3199    };
3200
3201    // ### %make-package
3202    // %make-package package-name nicknames use => package
3203    private static final Primitive _MAKE_PACKAGE = new pf__make_package();
3204    private static final class pf__make_package extends Primitive {
3205        pf__make_package() {
3206            super("%make-package", PACKAGE_SYS, false);
3207        }
3208
3209        /**
3210         * This invocation is solely used to be able to create
3211         * a package to bind to *FASL-ANONYMOUS-PACKAGE*
3212         */
3213        @Override
3214        public LispObject execute()
3215
3216        {
3217            return new Package();
3218        }
3219
3220        /**
3221         * This invocation is used by MAKE-PACKAGE to create a package
3222         */
3223        @Override
3224        public LispObject execute(LispObject first, LispObject second,
3225                                  LispObject third)
3226
3227        {
3228            String packageName = javaString(first);
3229            Package currentpkg = getCurrentPackage();
3230            Package pkg = currentpkg.findPackage(packageName);
3231            if (pkg != null)
3232                error(new LispError("Package " + packageName +
3233                                    " already exists."));
3234            LispObject nicknames = checkList(second);
3235            if (nicknames != NIL) {
3236                LispObject list = nicknames;
3237                while (list != NIL) {
3238                    String nick = javaString(list.car());
3239                    if (currentpkg.findPackage(nick) != null) {
3240                        error(new PackageError("A package named " + nick +
3241                                               " already exists."));
3242                    }
3243                    list = list.cdr();
3244                }
3245            }
3246            LispObject use = checkList(third);
3247            if (use != NIL) {
3248                LispObject list = use;
3249                while (list != NIL) {
3250                    LispObject obj = list.car();
3251                    if (obj instanceof Package) {
3252                        // OK.
3253                    } else {
3254                        String s = javaString(obj);
3255                        Package p = currentpkg.findPackage(s);
3256                        if (p == null) {
3257                            error(new LispError(obj.princToString() +
3258                                                " is not the name of a package."));
3259                            return NIL;
3260                        }
3261                    }
3262                    list = list.cdr();
3263                }
3264            }
3265            // Now create the package.
3266            pkg = Packages.createPackage(packageName);
3267            // Add the nicknames.
3268            while (nicknames != NIL) {
3269                String nick = javaString(nicknames.car());
3270                pkg.addNickname(nick);
3271                nicknames = nicknames.cdr();
3272            }
3273            // Create the use list.
3274            while (use != NIL) {
3275                LispObject obj = use.car();
3276                if (obj instanceof Package)
3277                    pkg.usePackage((Package)obj);
3278                else {
3279                    String s = javaString(obj);
3280                    Package p = currentpkg.findPackage(s);
3281                    if (p == null) {
3282                        error(new LispError(obj.princToString() +
3283                                            " is not the name of a package."));
3284                        return NIL;
3285                    }
3286                    pkg.usePackage(p);
3287                }
3288                use = use.cdr();
3289            }
3290            return pkg;
3291        }
3292    };
3293
3294    // ### %in-package
3295    private static final Primitive _IN_PACKAGE = new pf__in_package();
3296    private static final class pf__in_package extends Primitive {
3297        pf__in_package() {
3298            super("%in-package", PACKAGE_SYS, true);
3299        }
3300
3301        @Override
3302        public LispObject execute(LispObject arg) {
3303            final String packageName = javaString(arg);
3304            final Package pkg = getCurrentPackage().findPackage(packageName);
3305            if (pkg == null)
3306                return error(new PackageError("The name " + packageName +
3307                                              " does not designate any package."));
3308            SpecialBinding binding =
3309                LispThread.currentThread().getSpecialBinding(Symbol._PACKAGE_);
3310            if (binding != null)
3311                binding.value = pkg;
3312            else
3313                // No dynamic binding.
3314                Symbol._PACKAGE_.setSymbolValue(pkg);
3315            return pkg;
3316        }
3317    };
3318
3319    // ### use-package packages-to-use &optional package => t
3320    private static final Primitive USE_PACKAGE = new pf_use_package();
3321    private static final class pf_use_package extends Primitive {
3322        pf_use_package() {
3323            super(Symbol.USE_PACKAGE, "packages-to-use &optional package");
3324        }
3325
3326        @Override
3327        public LispObject execute(LispObject[] args) {
3328            if (args.length < 1 || args.length > 2)
3329                return error(new WrongNumberOfArgumentsException(this, 1, 2));
3330            Package pkg;
3331            if (args.length == 2)
3332                pkg = coerceToPackage(args[1]);
3333            else
3334                pkg = getCurrentPackage();
3335            if (args[0].listp()) {
3336                LispObject list = args[0];
3337                while (list != NIL) {
3338                    pkg.usePackage(coerceToPackage(list.car()));
3339                    list = list.cdr();
3340                }
3341            } else
3342                pkg.usePackage(coerceToPackage(args[0]));
3343            return T;
3344        }
3345    };
3346
3347    // ### package-symbols
3348    private static final Primitive PACKAGE_SYMBOLS = new pf_package_symbols();
3349    private static final class pf_package_symbols extends Primitive {
3350        pf_package_symbols() {
3351            super("package-symbols", PACKAGE_SYS, true);
3352        }
3353
3354        @Override
3355        public LispObject execute(LispObject arg) {
3356            return coerceToPackage(arg).getSymbols();
3357        }
3358    };
3359
3360    // ### package-internal-symbols
3361    private static final Primitive PACKAGE_INTERNAL_SYMBOLS = new pf_package_internal_symbols();
3362    private static final class pf_package_internal_symbols extends Primitive {
3363        pf_package_internal_symbols() {
3364            super("package-internal-symbols", PACKAGE_SYS, true);
3365        }
3366
3367        @Override
3368        public LispObject execute(LispObject arg) {
3369            return coerceToPackage(arg).PACKAGE_INTERNAL_SYMBOLS();
3370        }
3371    };
3372
3373    // ### package-external-symbols
3374    private static final Primitive PACKAGE_EXTERNAL_SYMBOLS = new pf_package_external_symbols();
3375    private static final class pf_package_external_symbols extends Primitive {
3376        pf_package_external_symbols() {
3377            super("package-external-symbols", PACKAGE_SYS, true);
3378        }
3379
3380        @Override
3381        public LispObject execute(LispObject arg) {
3382            return coerceToPackage(arg).PACKAGE_EXTERNAL_SYMBOLS();
3383        }
3384    };
3385
3386    // ### package-inherited-symbols
3387    private static final Primitive PACKAGE_INHERITED_SYMBOLS = new pf_package_inherited_symbols();
3388    private static final class pf_package_inherited_symbols extends Primitive {
3389        pf_package_inherited_symbols() {
3390            super("package-inherited-symbols", PACKAGE_SYS, true);
3391        }
3392
3393        @Override
3394        public LispObject execute(LispObject arg) {
3395            return coerceToPackage(arg).PACKAGE_INHERITED_SYMBOLS();
3396        }
3397    };
3398
3399    // ### export symbols &optional package
3400    private static final Primitive EXPORT = new pf_export();
3401    private static final class pf_export extends Primitive {
3402        pf_export() {
3403            super(Symbol.EXPORT, "symbols &optional package");
3404        }
3405
3406        @Override
3407        public LispObject execute(LispObject arg) {
3408            final Package pkg = (Package) Symbol._PACKAGE_.symbolValue();
3409            if (arg instanceof Cons) {
3410                for (LispObject list = arg; list != NIL; list = list.cdr())
3411                    pkg.export(checkSymbol(list.car()));
3412            } else
3413                pkg.export(checkSymbol(arg));
3414            return T;
3415        }
3416
3417        @Override
3418        public LispObject execute(LispObject first, LispObject second)
3419
3420        {
3421            if (first instanceof Cons) {
3422                Package pkg = coerceToPackage(second);
3423                for (LispObject list = first; list != NIL; list = list.cdr())
3424                    pkg.export(checkSymbol(list.car()));
3425            } else
3426                coerceToPackage(second).export(checkSymbol(first));
3427            return T;
3428        }
3429    };
3430
3431    // ### find-symbol string &optional package => symbol, status
3432    private static final Primitive FIND_SYMBOL = new pf_find_symbol();
3433    private static final class pf_find_symbol extends Primitive {
3434        pf_find_symbol() {
3435            super(Symbol.FIND_SYMBOL, "string &optional package");
3436        }
3437
3438        @Override
3439        public LispObject execute(LispObject arg) {
3440            return getCurrentPackage()
3441                   .findSymbol(checkString(arg).getStringValue());
3442        }
3443
3444        @Override
3445        public LispObject execute(LispObject first, LispObject second)
3446
3447        {
3448            return coerceToPackage(second)
3449                   .findSymbol(checkString(first).getStringValue());
3450        }
3451    };
3452
3453    // ### fset name function &optional source-position arglist documentation
3454    // => function
3455    private static final Primitive FSET = new pf_fset();
3456    private static final class pf_fset extends Primitive {
3457        pf_fset() {
3458            super("fset", PACKAGE_SYS, true);
3459        }
3460
3461        @Override
3462        public LispObject execute(LispObject first, LispObject second)
3463
3464        {
3465            return execute(first, second, NIL, NIL, NIL);
3466        }
3467        @Override
3468        public LispObject execute(LispObject first, LispObject second,
3469                                  LispObject third)
3470
3471        {
3472            return execute(first, second, third, NIL, NIL);
3473        }
3474        @Override
3475        public LispObject execute(LispObject first, LispObject second,
3476                                  LispObject third, LispObject fourth)
3477
3478        {
3479            return execute(first, second, third, fourth, NIL);
3480        }
3481        @Override
3482        public LispObject execute(LispObject first, LispObject second,
3483                                  LispObject third, LispObject fourth,
3484                                  LispObject fifth)
3485
3486        {
3487            if (first instanceof Symbol) {
3488                checkRedefinition(first);
3489                Symbol symbol = checkSymbol(first);
3490                symbol.setSymbolFunction(second);
3491                final LispThread thread = LispThread.currentThread();
3492                LispObject sourcePathname = _SOURCE_.symbolValue(thread);
3493                LispObject sourcePosition = third;
3494                if (sourcePathname != NIL)
3495                    sourcePosition = _SOURCE_POSITION_.symbolValue(thread);
3496                if (sourcePathname == NIL)
3497                    sourcePathname = Keyword.TOP_LEVEL;
3498                if (sourcePathname != Keyword.TOP_LEVEL)
3499                    put(symbol, Symbol._SOURCE, new Cons(sourcePathname, third));
3500                else
3501                    put(symbol, Symbol._SOURCE, sourcePathname);
3502            } else if (isValidSetfFunctionName(first)) {
3503                // SETF function
3504                checkRedefinition(first);
3505                Symbol symbol = checkSymbol(first.cadr());
3506                put(symbol, Symbol.SETF_FUNCTION, second);
3507            } else
3508                return type_error(first, FUNCTION_NAME);
3509            if (second instanceof Operator) {
3510                Operator op = (Operator) second;
3511                op.setLambdaName(first);
3512                if (fourth != NIL)
3513                    op.setLambdaList(fourth);
3514                if (fifth != NIL)
3515                    op.setDocumentation(Symbol.FUNCTION, fifth);
3516            }
3517            return second;
3518        }
3519    };
3520
3521    // ### %set-symbol-plist
3522    private static final Primitive _SET_SYMBOL_PLIST = new pf__set_symbol_plist();
3523    private static final class pf__set_symbol_plist extends Primitive {
3524        pf__set_symbol_plist() {
3525            super("%set-symbol-plist", PACKAGE_SYS, false);
3526        }
3527
3528        @Override
3529        public LispObject execute(LispObject first, LispObject second)
3530
3531        {
3532            checkSymbol(first).setPropertyList(checkList(second));
3533            return second;
3534        }
3535    };
3536
3537    // ### getf plist indicator &optional default => value
3538    private static final Primitive GETF = new pf_getf();
3539    private static final class pf_getf extends Primitive {
3540        pf_getf() {
3541            super(Symbol.GETF, "plist indicator &optional default");
3542        }
3543
3544        @Override
3545        public LispObject execute(LispObject plist, LispObject indicator)
3546
3547        {
3548            return getf(plist, indicator, NIL);
3549        }
3550        @Override
3551        public LispObject execute(LispObject plist, LispObject indicator,
3552                                  LispObject defaultValue)
3553
3554        {
3555            return getf(plist, indicator, defaultValue);
3556        }
3557    };
3558
3559    // ### get symbol indicator &optional default => value
3560    private static final Primitive GET = new pf_get();
3561    private static final class pf_get extends Primitive {
3562        pf_get() {
3563            super(Symbol.GET, "symbol indicator &optional default");
3564        }
3565
3566        @Override
3567        public LispObject execute(LispObject symbol, LispObject indicator)
3568
3569        {
3570            return get(symbol, indicator, NIL);
3571        }
3572        @Override
3573        public LispObject execute(LispObject symbol, LispObject indicator,
3574                                  LispObject defaultValue)
3575
3576        {
3577            return get(symbol, indicator, defaultValue);
3578        }
3579    };
3580
3581    // ### put symbol indicator value => value
3582    public static final Primitive PUT = new pf_put();
3583    private static final class pf_put extends Primitive {
3584        pf_put() {
3585            super("put", PACKAGE_SYS, true);
3586        }
3587
3588        @Override
3589        public LispObject execute(LispObject symbol, LispObject indicator,
3590                                  LispObject value)
3591
3592        {
3593            return put(checkSymbol(symbol), indicator, value);
3594        }
3595        @Override
3596        public LispObject execute(LispObject symbol, LispObject indicator,
3597                                  LispObject defaultValue, LispObject value)
3598
3599        {
3600            return put(checkSymbol(symbol), indicator, value);
3601        }
3602    };
3603
3604    // ### macrolet
3605    private static final SpecialOperator MACROLET = new sf_macrolet();
3606    private static final class sf_macrolet extends SpecialOperator {
3607        sf_macrolet() {
3608            super(Symbol.MACROLET, "definitions &rest body");
3609        }
3610
3611        @Override
3612        public LispObject execute(LispObject args, Environment env)
3613
3614        {
3615            LispObject defs = checkList(args.car());
3616            final LispThread thread = LispThread.currentThread();
3617            final SpecialBindingsMark mark = thread.markSpecialBindings();
3618
3619            try {
3620                Environment ext = new Environment(env);
3621                while (defs != NIL) {
3622                    LispObject def = checkList(defs.car());
3623                    Symbol symbol = checkSymbol(def.car());
3624                    Symbol make_expander_for_macrolet =
3625                        PACKAGE_SYS.intern("MAKE-MACRO-EXPANDER");
3626                    LispObject expander =
3627                        make_expander_for_macrolet.execute(def);
3628                    Closure expansionFunction = new Closure(expander, env);
3629                    MacroObject macroObject =
3630                        new MacroObject(symbol, expansionFunction);
3631                    ext.addFunctionBinding(symbol, macroObject);
3632                    defs = defs.cdr();
3633                }
3634                return progn(ext.processDeclarations(args.cdr()), ext, thread);
3635            }
3636            finally {
3637                thread.resetSpecialBindings(mark);
3638            }
3639        }
3640    };
3641
3642    private static final Primitive MAKE_MACRO_EXPANDER = new pf_make_macro_expander();
3643    private static final class pf_make_macro_expander extends Primitive {
3644        pf_make_macro_expander() {
3645            super("make-macro-expander", PACKAGE_SYS, true, "definition");
3646        }
3647
3648        @Override
3649        public LispObject execute(LispObject definition)
3650
3651        {
3652            /* Create an expansion function
3653             * `(lambda (,formArg ,envArg)
3654             *     (apply (function (macro-function ,lambdaList
3655             *                         (block ,symbol ,@body)))
3656             *            (cdr ,formArg)))
3657             */
3658            Symbol symbol = checkSymbol(definition.car());
3659            LispObject lambdaList = definition.cadr();
3660            LispObject body = definition.cddr();
3661            LispObject block =
3662                new Cons(Symbol.BLOCK, new Cons(symbol, body));
3663            LispObject toBeApplied =
3664                list(Symbol.FUNCTION, list(Symbol.MACRO_FUNCTION, lambdaList, block));
3665            final LispThread thread = LispThread.currentThread();
3666            LispObject formArg = gensym("WHOLE-", thread);
3667            LispObject envArg = gensym("ENVIRONMENT-", thread); // Ignored.
3668            LispObject expander =
3669                list(Symbol.LAMBDA, list(formArg, envArg),
3670                     list(Symbol.APPLY, toBeApplied,
3671                          list(Symbol.CDR, formArg)));
3672            return expander;
3673        }
3674    };
3675
3676    // ### tagbody
3677    private static final SpecialOperator TAGBODY = new sf_tagbody();
3678    private static final class sf_tagbody extends SpecialOperator {
3679        sf_tagbody() {
3680            super(Symbol.TAGBODY, "&rest statements");
3681        }
3682
3683        @Override
3684        public LispObject execute(LispObject args, Environment env)
3685
3686        {
3687            Environment ext = new Environment(env);
3688            try {
3689                return processTagBody(args, preprocessTagBody(args, ext), ext);
3690            }
3691            finally {
3692                ext.inactive = true;
3693            }
3694        }
3695    };
3696
3697    // ### go
3698    private static final SpecialOperator GO = new sf_go();
3699    private static final class sf_go extends SpecialOperator {
3700        sf_go() {
3701            super(Symbol.GO, "tag");
3702        }
3703
3704        @Override
3705        public LispObject execute(LispObject args, Environment env)
3706
3707        {
3708            if (args.length() != 1)
3709                return error(new WrongNumberOfArgumentsException(this, 1));
3710            Binding binding = env.getTagBinding(args.car());
3711            if (binding == null)
3712                return error(new ControlError("No tag named " +
3713                                              args.car().princToString() +
3714                                              " is currently visible."));
3715
3716            return nonLocalGo(binding, args.car());
3717        }
3718    };
3719
3720    // ### block
3721    private static final SpecialOperator BLOCK = new sf_block();
3722    private static final class sf_block extends SpecialOperator {
3723        sf_block() {
3724            super(Symbol.BLOCK, "name &rest forms");
3725        }
3726
3727        @Override
3728        public LispObject execute(LispObject args, Environment env)
3729
3730        {
3731            if (args == NIL)
3732                return error(new WrongNumberOfArgumentsException(this, 1, -1));
3733            LispObject tag;
3734            tag = checkSymbol(args.car());
3735            LispObject body = ((Cons)args).cdr();
3736            Environment ext = new Environment(env);
3737            final LispObject block = new LispObject();
3738            ext.addBlock(tag, block);
3739            LispObject result = NIL;
3740            final LispThread thread = LispThread.currentThread();
3741            try {
3742                return progn(body, ext, thread);
3743            } catch (Return ret) {
3744                if (ret.getBlock() == block) {
3745                    return ret.getResult();
3746                }
3747                throw ret;
3748            }
3749            finally {
3750                ext.inactive = true;
3751            }
3752        }
3753    };
3754
3755    // ### return-from
3756    private static final SpecialOperator RETURN_FROM = new sf_return_from();
3757    private static final class sf_return_from extends SpecialOperator {
3758        sf_return_from() {
3759            super(Symbol.RETURN_FROM, "name &optional value");
3760        }
3761
3762        @Override
3763        public LispObject execute(LispObject args, Environment env)
3764
3765        {
3766            final int length = args.length();
3767            if (length < 1 || length > 2)
3768                return error(new WrongNumberOfArgumentsException(this, 1, 2));
3769            Symbol symbol;
3770            symbol = checkSymbol(args.car());
3771
3772            return nonLocalReturn(env.getBlockBinding(symbol), symbol,
3773                                  (length == 2) ? eval(args.cadr(), env,
3774                                                       LispThread.currentThread())
3775                                  : NIL);
3776        }
3777    };
3778
3779    // ### catch
3780    private static final SpecialOperator CATCH = new sf_catch();
3781    private static final class sf_catch extends SpecialOperator {
3782        sf_catch() {
3783            super(Symbol.CATCH, "tag &body body");
3784        }
3785
3786        @Override
3787        public LispObject execute(LispObject args, Environment env)
3788
3789        {
3790            if (args.length() < 1)
3791                return error(new WrongNumberOfArgumentsException(this, 1, -1));
3792            final LispThread thread = LispThread.currentThread();
3793            LispObject tag = eval(args.car(), env, thread);
3794            thread.pushCatchTag(tag);
3795            LispObject body = args.cdr();
3796            LispObject result = NIL;
3797            try {
3798                return progn(body, env, thread);
3799            } catch (Throw t) {
3800                if (t.tag == tag) {
3801                    return t.getResult(thread);
3802                }
3803                throw t;
3804            } catch (Return ret) {
3805                throw ret;
3806            }
3807            finally {
3808                thread.popCatchTag();
3809            }
3810        }
3811    };
3812
3813    // ### throw
3814    private static final SpecialOperator THROW = new sf_throw();
3815    private static final class sf_throw extends SpecialOperator {
3816        sf_throw() {
3817            super(Symbol.THROW, "tag result");
3818        }
3819
3820        @Override
3821        public LispObject execute(LispObject args, Environment env)
3822
3823        {
3824            if (args.length() != 2)
3825                return error(new WrongNumberOfArgumentsException(this, 2));
3826            final LispThread thread = LispThread.currentThread();
3827            thread.throwToTag(eval(args.car(), env, thread),
3828                              eval(args.cadr(), env, thread));
3829            // Not reached.
3830            return NIL;
3831        }
3832    };
3833
3834    // ### unwind-protect
3835    private static final SpecialOperator UNWIND_PROTECT = new sf_unwind_protect();
3836    private static final class sf_unwind_protect extends SpecialOperator {
3837        sf_unwind_protect() {
3838            super(Symbol.UNWIND_PROTECT, "protected &body cleanup");
3839        }
3840
3841        @Override
3842        public LispObject execute(LispObject args, Environment env)
3843
3844        {
3845            final LispThread thread = LispThread.currentThread();
3846            LispObject result;
3847            LispObject[] values;
3848            try {
3849                result = eval(args.car(), env, thread);
3850            }
3851            finally {
3852                values = thread._values;
3853                LispObject body = args.cdr();
3854                while (body != NIL) {
3855                    eval(body.car(), env, thread);
3856                    body = ((Cons)body).cdr;
3857                }
3858                thread._values = values;
3859            }
3860            if (values != null)
3861                thread.setValues(values);
3862            else
3863                thread._values = null;
3864            return result;
3865        }
3866    };
3867
3868    // ### eval-when
3869    private static final SpecialOperator EVAL_WHEN = new sf_eval_when();
3870    private static final class sf_eval_when extends SpecialOperator {
3871        sf_eval_when() {
3872            super(Symbol.EVAL_WHEN, "situations &rest forms");
3873        }
3874
3875        @Override
3876        public LispObject execute(LispObject args, Environment env)
3877
3878        {
3879            LispObject situations = args.car();
3880            if (situations != NIL) {
3881                if (memq(Keyword.EXECUTE, situations) ||
3882                        memq(Symbol.EVAL, situations)) {
3883                    return progn(args.cdr(), env, LispThread.currentThread());
3884                }
3885            }
3886            return NIL;
3887        }
3888    };
3889
3890    // ### multiple-value-bind
3891    // multiple-value-bind (var*) values-form declaration* form*
3892    // Should be a macro.
3893    private static final SpecialOperator MULTIPLE_VALUE_BIND = new sf_multiple_value_bind();
3894    private static final class sf_multiple_value_bind extends SpecialOperator {
3895        sf_multiple_value_bind() {
3896            super(Symbol.MULTIPLE_VALUE_BIND,
3897                  "vars value-form &body body");
3898        }
3899
3900        @Override
3901        public LispObject execute(LispObject args, Environment env)
3902
3903        {
3904            LispObject vars = args.car();
3905            args = args.cdr();
3906            LispObject valuesForm = args.car();
3907            LispObject body = args.cdr();
3908            final LispThread thread = LispThread.currentThread();
3909            LispObject value = eval(valuesForm, env, thread);
3910            LispObject[] values = thread._values;
3911            if (values == null) {
3912                // eval() did not return multiple values.
3913                values = new LispObject[1];
3914                values[0] = value;
3915            }
3916            // Process declarations.
3917            LispObject bodyAndDecls = parseBody(body, false);
3918            LispObject specials = parseSpecials(bodyAndDecls.NTH(1));
3919            body = bodyAndDecls.car();
3920
3921            final SpecialBindingsMark mark = thread.markSpecialBindings();
3922            final Environment ext = new Environment(env);
3923            int i = 0;
3924            LispObject var = vars.car();
3925            while (var != NIL) {
3926                final Symbol sym;
3927
3928                sym =  checkSymbol(var);
3929
3930                LispObject val = i < values.length ? values[i] : NIL;
3931                if (specials != NIL && memq(sym, specials)) {
3932                    thread.bindSpecial(sym, val);
3933                    ext.declareSpecial(sym);
3934                } else if (sym.isSpecialVariable()) {
3935                    thread.bindSpecial(sym, val);
3936                } else
3937                    ext.bind(sym, val);
3938                vars = vars.cdr();
3939                var = vars.car();
3940                ++i;
3941            }
3942            // Make sure free special declarations are visible in the body.
3943            // "The scope of free declarations specifically does not include
3944            // initialization forms for bindings established by the form
3945            // containing the declarations." (3.3.4)
3946            while (specials != NIL) {
3947                Symbol symbol = (Symbol) specials.car();
3948                ext.declareSpecial(symbol);
3949                specials = ((Cons)specials).cdr;
3950            }
3951            thread._values = null;
3952            LispObject result = NIL;
3953            try {
3954                result  = progn(body, ext, thread);
3955            }
3956            finally {
3957                thread.resetSpecialBindings(mark);
3958            }
3959            return result;
3960        }
3961    };
3962
3963    // ### multiple-value-prog1
3964    private static final SpecialOperator MULTIPLE_VALUE_PROG1 = new sf_multiple_value_prog1();
3965    private static final class sf_multiple_value_prog1 extends SpecialOperator {
3966        sf_multiple_value_prog1() {
3967            super(Symbol.MULTIPLE_VALUE_PROG1,
3968                  "values-form &rest forms");
3969        }
3970
3971        @Override
3972        public LispObject execute(LispObject args, Environment env)
3973
3974        {
3975            if (args.length() == 0)
3976                return error(new WrongNumberOfArgumentsException(this, 1, -1));
3977            final LispThread thread = LispThread.currentThread();
3978            LispObject result = eval(args.car(), env, thread);
3979            LispObject[] values = thread._values;
3980            while ((args = args.cdr()) != NIL)
3981                eval(args.car(), env, thread);
3982            if (values != null)
3983                thread.setValues(values);
3984            else
3985                thread._values = null;
3986            return result;
3987        }
3988    };
3989
3990    // ### multiple-value-call
3991    private static final SpecialOperator MULTIPLE_VALUE_CALL = new sf_multiple_value_call();
3992    private static final class sf_multiple_value_call extends SpecialOperator {
3993        sf_multiple_value_call() {
3994            super(Symbol.MULTIPLE_VALUE_CALL, "fun &rest args");
3995        }
3996
3997        @Override
3998        public LispObject execute(LispObject args, Environment env)
3999
4000        {
4001            if (args.length() == 0)
4002                return error(new WrongNumberOfArgumentsException(this, 1, -1));
4003            final LispThread thread = LispThread.currentThread();
4004            LispObject function;
4005            LispObject obj = eval(args.car(), env, thread);
4006            args = args.cdr();
4007            if (obj instanceof Symbol) {
4008                function = obj.getSymbolFunction();
4009                if (function == null)
4010                    error(new UndefinedFunction(obj));
4011            } else if (obj instanceof Function) {
4012                function = obj;
4013            } else {
4014                error(new LispError(obj.princToString() +
4015                                    " is not a function name."));
4016                return NIL;
4017            }
4018            ArrayList<LispObject> arrayList = new ArrayList<LispObject>();
4019            while (args != NIL) {
4020                LispObject form = args.car();
4021                LispObject result = eval(form, env, thread);
4022                LispObject[] values = thread._values;
4023                if (values != null) {
4024                    for (int i = 0; i < values.length; i++)
4025                        arrayList.add(values[i]);
4026                } else
4027                    arrayList.add(result);
4028                args = ((Cons)args).cdr;
4029            }
4030            LispObject[] argv = new LispObject[arrayList.size()];
4031            arrayList.toArray(argv);
4032            return funcall(function, argv, thread);
4033        }
4034    };
4035
4036    // ### and
4037    // Should be a macro.
4038    private static final SpecialOperator AND = new sf_and();
4039    private static final class sf_and extends SpecialOperator {
4040        sf_and() {
4041            super(Symbol.AND, "&rest forms");
4042        }
4043
4044        @Override
4045        public LispObject execute(LispObject args, Environment env)
4046
4047        {
4048            final LispThread thread = LispThread.currentThread();
4049            LispObject result = T;
4050            while (args != NIL) {
4051                result = eval(args.car(), env, thread);
4052                if (result == NIL) {
4053                    if (((Cons)args).cdr != NIL) {
4054                        // Not the last form.
4055                        thread._values = null;
4056                    }
4057                    break;
4058                }
4059                args = ((Cons)args).cdr;
4060            }
4061            return result;
4062        }
4063    };
4064
4065    // ### or
4066    // Should be a macro.
4067    private static final SpecialOperator OR = new sf_or();
4068    private static final class sf_or extends SpecialOperator {
4069        sf_or() {
4070            super(Symbol.OR, "&rest forms");
4071        }
4072
4073        @Override
4074        public LispObject execute(LispObject args, Environment env)
4075
4076        {
4077            final LispThread thread = LispThread.currentThread();
4078            LispObject result = NIL;
4079            while (args != NIL) {
4080                result = eval(args.car(), env, thread);
4081                if (result != NIL) {
4082                    if (((Cons)args).cdr != NIL) {
4083                        // Not the last form.
4084                        thread._values = null;
4085                    }
4086                    break;
4087                }
4088                args = ((Cons)args).cdr;
4089            }
4090            return result;
4091        }
4092    };
4093
4094    // ### multiple-value-list form => list
4095    // Evaluates form and creates a list of the multiple values it returns.
4096    // Should be a macro.
4097    private static final SpecialOperator MULTIPLE_VALUE_LIST = new sf_multiple_value_list();
4098    private static final class sf_multiple_value_list extends SpecialOperator {
4099        sf_multiple_value_list() {
4100            super(Symbol.MULTIPLE_VALUE_LIST, "value-form");
4101        }
4102
4103        @Override
4104        public LispObject execute(LispObject args, Environment env)
4105
4106        {
4107            if (args.length() != 1)
4108                return error(new WrongNumberOfArgumentsException(this, 1));
4109            final LispThread thread = LispThread.currentThread();
4110            LispObject result = eval(((Cons)args).car, env, thread);
4111            LispObject[] values = thread._values;
4112            if (values == null)
4113                return new Cons(result);
4114            thread._values = null;
4115            LispObject list = NIL;
4116            for (int i = values.length; i-- > 0;)
4117                list = new Cons(values[i], list);
4118            return list;
4119        }
4120    };
4121
4122    // ### nth-value n form => object
4123    // Evaluates n and then form and returns the nth value returned by form, or
4124    // NIL if n >= number of values returned.
4125    // Should be a macro.
4126    private static final SpecialOperator NTH_VALUE = new sf_nth_value();
4127    private static final class sf_nth_value extends SpecialOperator {
4128        sf_nth_value() {
4129            super(Symbol.NTH_VALUE, "n form");
4130        }
4131
4132        @Override
4133        public LispObject execute(LispObject args, Environment env)
4134
4135        {
4136            if (args.length() != 2)
4137                return error(new WrongNumberOfArgumentsException(this, 2));
4138            final LispThread thread = LispThread.currentThread();
4139            int n = Fixnum.getValue(eval(args.car(), env, thread));
4140            if (n < 0)
4141                n = 0;
4142            LispObject result = eval(args.cadr(), env, thread);
4143            LispObject[] values = thread._values;
4144            thread._values = null;
4145            if (values == null) {
4146                // A single value was returned.
4147                return n == 0 ? result : NIL;
4148            }
4149            if (n < values.length)
4150                return values[n];
4151            return NIL;
4152        }
4153    };
4154
4155    // ### call-count
4156    private static final Primitive CALL_COUNT = new pf_call_count();
4157    private static final class pf_call_count extends Primitive {
4158        pf_call_count() {
4159            super("call-count", PACKAGE_SYS, true);
4160        }
4161
4162        @Override
4163        public LispObject execute(LispObject arg) {
4164            return Fixnum.getInstance(arg.getCallCount());
4165        }
4166    };
4167
4168    // ### set-call-count
4169    private static final Primitive SET_CALL_COUNT = new pf_set_call_count();
4170    private static final class pf_set_call_count extends Primitive {
4171        pf_set_call_count() {
4172            super("set-call-count", PACKAGE_SYS, true);
4173        }
4174
4175        @Override
4176        public LispObject execute(LispObject first, LispObject second)
4177
4178        {
4179            first.setCallCount(Fixnum.getValue(second));
4180            return second;
4181        }
4182    };
4183
4184    // ### hot-count
4185    private static final Primitive HOT_COUNT = new pf_hot_count();
4186    private static final class pf_hot_count extends Primitive {
4187        pf_hot_count() {
4188            super("hot-count", PACKAGE_SYS, true);
4189        }
4190
4191        @Override
4192        public LispObject execute(LispObject arg) {
4193            return Fixnum.getInstance(arg.getHotCount());
4194        }
4195    };
4196
4197    // ### set-hot-count
4198    private static final Primitive SET_HOT_COUNT = new pf_set_hot_count();
4199    private static final class pf_set_hot_count extends Primitive {
4200        pf_set_hot_count() {
4201            super("set-hot-count", PACKAGE_SYS, true);
4202        }
4203
4204        @Override
4205        public LispObject execute(LispObject first, LispObject second)
4206
4207        {
4208            first.setHotCount(Fixnum.getValue(second));
4209            return second;
4210        }
4211    };
4212
4213    // ### lambda-name
4214    private static final Primitive LAMBDA_NAME = new pf_lambda_name();
4215    private static final class pf_lambda_name extends Primitive {
4216        pf_lambda_name() {
4217            super("lambda-name", PACKAGE_SYS, true);
4218        }
4219
4220        @Override
4221        public LispObject execute(LispObject arg) {
4222            if (arg instanceof Operator) {
4223                return ((Operator)arg).getLambdaName();
4224            }
4225            if (arg.typep(Symbol.GENERIC_FUNCTION) != NIL) {
4226                return Symbol.GENERIC_FUNCTION_NAME.execute(arg);
4227            }
4228            if (arg instanceof FuncallableStandardObject) {
4229              return this.execute(((FuncallableStandardObject)arg).function);
4230            }
4231            return type_error(arg, Symbol.FUNCTION);
4232        }
4233    };
4234
4235    // ### %set-lambda-name
4236    private static final Primitive _SET_LAMBDA_NAME = new pf__set_lambda_name();
4237    private static final class pf__set_lambda_name extends Primitive {
4238        pf__set_lambda_name() {
4239            super("%set-lambda-name", PACKAGE_SYS, false);
4240        }
4241
4242        @Override
4243        public LispObject execute(LispObject first, LispObject second)
4244
4245        {
4246            if (first instanceof Operator) {
4247                ((Operator)first).setLambdaName(second);
4248                return second;
4249            }
4250            // KLUDGE: this isn't fully general, but lots of other stuff
4251            // will break for generic functions that aren't subclasses
4252            // of standard-generic-function as well.
4253            if (first.typep(Symbol.STANDARD_GENERIC_FUNCTION) != NIL) {
4254                ((StandardObject)first).setInstanceSlotValue(Symbol.NAME, second);
4255                return second;
4256            }
4257            if (first instanceof FuncallableStandardObject) {
4258              return this.execute(((FuncallableStandardObject)first).function, second);
4259            }
4260            return type_error(first, Symbol.FUNCTION);
4261        }
4262    };
4263
4264    // ### shrink-vector vector new-size => vector
4265    // Destructively alters the vector, changing its length to NEW-SIZE, which
4266    // must be less than or equal to its current length.
4267    // shrink-vector vector new-size => vector
4268    private static final Primitive SHRINK_VECTOR = new pf_shrink_vector();
4269    private static final class pf_shrink_vector extends Primitive {
4270        pf_shrink_vector() {
4271            super("shrink-vector", PACKAGE_SYS, true, "vector new-size");
4272        }
4273
4274        @Override
4275        public LispObject execute(LispObject first, LispObject second)
4276
4277        {
4278            checkVector(first).shrink(Fixnum.getValue(second));
4279            return first;
4280        }
4281    };
4282
4283    // ### subseq sequence start &optional end
4284    private static final Primitive SUBSEQ = new pf_subseq();
4285    private static final class pf_subseq extends Primitive {
4286        pf_subseq() {
4287            super(PACKAGE_SYS.intern("%SUBSEQ"), "sequence start &optional end");
4288        }
4289
4290        @Override
4291        public LispObject execute(LispObject first, LispObject second)
4292
4293        {
4294            final int start = Fixnum.getValue(second);
4295            if (start < 0) {
4296                StringBuilder sb = new StringBuilder("Bad start index (");
4297                sb.append(start);
4298                sb.append(") for SUBSEQ.");
4299                error(new TypeError(sb.toString()));
4300            }
4301            if (first.listp())
4302                return list_subseq(first, start, -1);
4303            if (first instanceof AbstractVector) {
4304                final AbstractVector v = (AbstractVector) first;
4305                return v.subseq(start, v.length());
4306            }
4307            return type_error(first, Symbol.SEQUENCE);
4308        }
4309        @Override
4310        public LispObject execute(LispObject first, LispObject second,
4311                                  LispObject third)
4312
4313        {
4314            final int start = Fixnum.getValue(second);
4315            if (start < 0) {
4316                StringBuilder sb = new StringBuilder("Bad start index (");
4317                sb.append(start);
4318                sb.append(").");
4319                error(new TypeError(sb.toString()));
4320            }
4321            int end;
4322            if (third != NIL) {
4323                end = Fixnum.getValue(third);
4324                if (start > end) {
4325                    StringBuilder sb = new StringBuilder("Start index (");
4326                    sb.append(start);
4327                    sb.append(") is greater than end index (");
4328                    sb.append(end);
4329                    sb.append(") for SUBSEQ.");
4330                    error(new TypeError(sb.toString()));
4331                }
4332            } else
4333                end = -1;
4334            if (first.listp())
4335                return list_subseq(first, start, end);
4336            if (first instanceof AbstractVector) {
4337                final AbstractVector v = (AbstractVector) first;
4338                if (end < 0)
4339                    end = v.length();
4340                return v.subseq(start, end);
4341            }
4342            return type_error(first, Symbol.SEQUENCE);
4343        }
4344    };
4345
4346    static final LispObject list_subseq(LispObject list, int start,
4347            int end)
4348
4349    {
4350        int index = 0;
4351        LispObject result = NIL;
4352        while (list != NIL) {
4353            if (end >= 0 && index == end)
4354                return result.nreverse();
4355            if (index++ >= start)
4356                result = new Cons(list.car(), result);
4357            list = list.cdr();
4358        }
4359        return result.nreverse();
4360    }
4361
4362    // ### list
4363    private static final Primitive LIST = new pf_list();
4364    private static final class pf_list extends Primitive {
4365        pf_list() {
4366            super(Symbol.LIST, "&rest objects");
4367        }
4368
4369        @Override
4370        public LispObject execute() {
4371            return NIL;
4372        }
4373        @Override
4374        public LispObject execute(LispObject arg) {
4375            return new Cons(arg);
4376        }
4377        @Override
4378        public LispObject execute(LispObject first, LispObject second) {
4379            return new Cons(first, new Cons(second));
4380        }
4381        @Override
4382        public LispObject execute(LispObject first, LispObject second,
4383                                  LispObject third) {
4384            return new Cons(first, new Cons(second, new Cons(third)));
4385        }
4386        @Override
4387        public LispObject execute(LispObject first, LispObject second,
4388                                  LispObject third, LispObject fourth) {
4389            return new Cons(first,
4390                            new Cons(second,
4391                                     new Cons(third,
4392                                              new Cons(fourth))));
4393        }
4394        @Override
4395        public LispObject execute(LispObject[] args) {
4396            LispObject result = NIL;
4397            for (int i = args.length; i-- > 0;)
4398                result = new Cons(args[i], result);
4399            return result;
4400        }
4401    };
4402
4403    // ### list*
4404    private static final Primitive LIST_STAR = new pf_list_star();
4405    private static final class pf_list_star extends Primitive {
4406        pf_list_star() {
4407            super(Symbol.LIST_STAR, "&rest objects");
4408        }
4409
4410        @Override
4411        public LispObject execute() {
4412            return error(new WrongNumberOfArgumentsException(this, 1, -1));
4413        }
4414        @Override
4415        public LispObject execute(LispObject arg) {
4416            return arg;
4417        }
4418        @Override
4419        public LispObject execute(LispObject first, LispObject second)
4420
4421        {
4422            return new Cons(first, second);
4423        }
4424        @Override
4425        public LispObject execute(LispObject first, LispObject second,
4426                                  LispObject third)
4427
4428        {
4429            return new Cons(first, new Cons(second, third));
4430        }
4431        @Override
4432        public LispObject execute(LispObject first, LispObject second,
4433                                  LispObject third, LispObject fourth)
4434
4435        {
4436            return new Cons(first,
4437                            new Cons(second,
4438                                     new Cons(third, fourth)));
4439        }
4440        @Override
4441        public LispObject execute(LispObject[] args) {
4442            int i = args.length - 1;
4443            LispObject result = args[i];
4444            while (i-- > 0)
4445                result = new Cons(args[i], result);
4446            return result;
4447        }
4448    };
4449
4450    // ### nreverse
4451    public static final Primitive NREVERSE = new pf_nreverse();
4452    private static final class pf_nreverse extends Primitive {
4453        pf_nreverse() {
4454            super("%NREVERSE", PACKAGE_SYS, false, "sequence");
4455        }
4456
4457        @Override
4458        public LispObject execute (LispObject arg) {
4459            return arg.nreverse();
4460        }
4461    };
4462
4463    // ### nreconc
4464    private static final Primitive NRECONC = new pf_nreconc();
4465    private static final class pf_nreconc extends Primitive {
4466        pf_nreconc() {
4467            super(Symbol.NRECONC, "list tail");
4468        }
4469
4470        @Override
4471        public LispObject execute(LispObject list, LispObject obj)
4472
4473        {
4474            if (list instanceof Cons) {
4475                LispObject list3 = list.cdr();
4476                if (list3 instanceof Cons) {
4477                    if (list3.cdr() instanceof Cons) {
4478                        LispObject list1 = list3;
4479                        LispObject list2 = NIL;
4480                        do {
4481                            LispObject h = list3.cdr();
4482                            list3.setCdr(list2);
4483                            list2 = list3;
4484                            list3 = h;
4485                        } while (list3.cdr() instanceof Cons);
4486                        list.setCdr(list2);
4487                        list1.setCdr(list3);
4488                    }
4489                    LispObject h = list.car();
4490                    list.setCar(list3.car());
4491                    list3.setCar(h);
4492                    list3.setCdr(obj);
4493                } else if (list3 == NIL) {
4494                    list.setCdr(obj);
4495                } else
4496                    type_error(list3, Symbol.LIST);
4497                return list;
4498            } else if (list == NIL)
4499                return obj;
4500            else
4501                return type_error(list, Symbol.LIST);
4502        }
4503    };
4504
4505    // ### reverse
4506    private static final Primitive REVERSE = new pf_reverse();
4507    private static final class pf_reverse extends Primitive {
4508        pf_reverse() {
4509            super("%reverse", PACKAGE_SYS, false, "sequence");
4510        }
4511
4512        @Override
4513        public LispObject execute(LispObject arg) {
4514            return arg.reverse();
4515        }
4516    };
4517
4518    // ### delete-eq item sequence => result-sequence
4519    private static final Primitive DELETE_EQ = new pf_delete_eq();
4520    private static final class pf_delete_eq extends Primitive {
4521        pf_delete_eq() {
4522            super("delete-eq", PACKAGE_SYS, true, "item sequence");
4523        }
4524
4525        @Override
4526        public LispObject execute(LispObject item, LispObject sequence)
4527
4528        {
4529            if (sequence instanceof AbstractVector)
4530                return ((AbstractVector)sequence).deleteEq(item);
4531            else
4532                return LIST_DELETE_EQ.execute(item, sequence);
4533        }
4534    };
4535
4536    // ### delete-eql item seqluence => result-seqluence
4537    private static final Primitive DELETE_EQL = new pf_delete_eql();
4538    private static final class pf_delete_eql extends Primitive {
4539        pf_delete_eql() {
4540            super("delete-eql", PACKAGE_SYS, true, "item sequence");
4541        }
4542
4543        @Override
4544        public LispObject execute(LispObject item, LispObject sequence)
4545
4546        {
4547            if (sequence instanceof AbstractVector)
4548                return ((AbstractVector)sequence).deleteEql(item);
4549            else
4550                return LIST_DELETE_EQL.execute(item, sequence);
4551        }
4552    };
4553
4554    // ### list-delete-eq item list => result-list
4555    static final Primitive LIST_DELETE_EQ = new pf_list_delete_eq();
4556    private static final class pf_list_delete_eq extends Primitive {
4557        pf_list_delete_eq() {
4558            super("list-delete-eq", PACKAGE_SYS, true, "item list");
4559        }
4560
4561        @Override
4562        public LispObject execute(LispObject item, LispObject list)
4563
4564        {
4565            if (list instanceof Cons) {
4566                LispObject tail = list;
4567                LispObject splice = list;
4568                while (tail instanceof Cons) {
4569                    LispObject car = tail.car();
4570                    if (car == item) {
4571                        if (tail.cdr() != NIL) {
4572                            LispObject temp = tail;
4573                            tail.setCar(temp.cadr());
4574                            tail.setCdr(temp.cddr());
4575                        } else {
4576                            // Last item.
4577                            if (tail == list)
4578                                return NIL;
4579                            splice.setCdr(NIL);
4580                            return list;
4581                        }
4582                    } else {
4583                        splice = tail;
4584                        tail = tail.cdr();
4585                    }
4586                }
4587                if (tail == NIL)
4588                    return list;
4589                else
4590                    return type_error(tail, Symbol.LIST);
4591            } else if (list == NIL)
4592                return list;
4593            else
4594                return type_error(list, Symbol.LIST);
4595        }
4596    };
4597
4598    // ### list-delete-eql item list => result-list
4599    static final Primitive LIST_DELETE_EQL = new pf_list_delete_eql();
4600    private static final class pf_list_delete_eql extends Primitive {
4601        pf_list_delete_eql() {
4602            super("list-delete-eql", PACKAGE_SYS, true, "item list");
4603        }
4604
4605        @Override
4606        public LispObject execute(LispObject item, LispObject list)
4607
4608        {
4609            if (list instanceof Cons) {
4610                LispObject tail = list;
4611                LispObject splice = list;
4612                while (tail instanceof Cons) {
4613                    LispObject car = tail.car();
4614                    if (car.eql(item)) {
4615                        if (tail.cdr() != NIL) {
4616                            LispObject temp = tail;
4617                            tail.setCar(temp.cadr());
4618                            tail.setCdr(temp.cddr());
4619                        } else {
4620                            // Last item.
4621                            if (tail == list)
4622                                return NIL;
4623                            splice.setCdr(NIL);
4624                            return list;
4625                        }
4626                    } else {
4627                        splice = tail;
4628                        tail = tail.cdr();
4629                    }
4630                }
4631                if (tail == NIL)
4632                    return list;
4633                else
4634                    return type_error(tail, Symbol.LIST);
4635            } else if (list == NIL)
4636                return list;
4637            else
4638                return type_error(list, Symbol.LIST);
4639        }
4640    };
4641
4642    // ### vector-delete-eq item vector => result-vector
4643    private static final Primitive VECTOR_DELETE_EQ = new pf_vector_delete_eq();
4644    private static final class pf_vector_delete_eq extends Primitive {
4645        pf_vector_delete_eq() {
4646            super("vector-delete-eq", PACKAGE_SYS, true, "item vector");
4647        }
4648
4649        @Override
4650        public LispObject execute(LispObject item, LispObject vector)
4651
4652        {
4653            checkVector(vector).deleteEq(item);
4654            return vector;
4655        }
4656    };
4657
4658    // ### vector-delete-eql item vector => result-vector
4659    private static final Primitive VECTOR_DELETE_EQL = new pf_vector_delete_eql();
4660    private static final class pf_vector_delete_eql extends Primitive {
4661        pf_vector_delete_eql() {
4662            super("vector-delete-eql", PACKAGE_SYS, true, "item vector");
4663        }
4664
4665        @Override
4666        public LispObject execute(LispObject item, LispObject vector)
4667
4668        {
4669            checkVector(vector).deleteEql(item);
4670            return vector;
4671        }
4672    };
4673
4674    // ### %set-elt
4675    // %setelt sequence index newval => newval
4676    private static final Primitive _SET_ELT = new pf__set_elt();
4677    private static final class pf__set_elt extends Primitive {
4678        pf__set_elt() {
4679            super("%set-elt", PACKAGE_SYS, false);
4680        }
4681
4682        @Override
4683        public LispObject execute(LispObject first, LispObject second,
4684                                  LispObject third)
4685
4686        {
4687            if (first instanceof AbstractVector) {
4688                ((AbstractVector)first).aset(Fixnum.getValue(second), third);
4689                return third;
4690            }
4691            if (first instanceof Cons) {
4692                int index = Fixnum.getValue(second);
4693                if (index < 0)
4694                    error(new TypeError());
4695                LispObject list = first;
4696                int i = 0;
4697                while (true) {
4698                    if (i == index) {
4699                        list.setCar(third);
4700                        return third;
4701                    }
4702                    list = list.cdr();
4703                    if (list == NIL)
4704                        error(new TypeError());
4705                    ++i;
4706                }
4707            }
4708            return type_error(first, Symbol.SEQUENCE);
4709        }
4710    };
4711
4712    // ### %make-list
4713    private static final Primitive _MAKE_LIST = new pf__make_list();
4714    private static final class pf__make_list extends Primitive {
4715        pf__make_list() {
4716            super("%make-list", PACKAGE_SYS, true);
4717        }
4718
4719        @Override
4720        public LispObject execute(LispObject first, LispObject second)
4721
4722        {
4723            int size = Fixnum.getValue(first);
4724            if (size < 0)
4725                return type_error(first, list(Symbol.INTEGER, Fixnum.ZERO,
4726                                              Symbol.MOST_POSITIVE_FIXNUM.getSymbolValue()));
4727            LispObject result = NIL;
4728            for (int i = size; i-- > 0;)
4729                result = new Cons(second, result);
4730            return result;
4731        }
4732    };
4733
4734    // ### %member item list key test test-not => tail
4735    private static final Primitive _MEMBER = new pf__member();
4736    private static final class pf__member extends Primitive {
4737        pf__member() {
4738            super("%member", PACKAGE_SYS, true);
4739        }
4740
4741        @Override
4742        public LispObject execute(LispObject item, LispObject list,
4743                                  LispObject key, LispObject test,
4744                                  LispObject testNot)
4745
4746        {
4747            LispObject tail = checkList(list);
4748            if (test != NIL && testNot != NIL)
4749                error(new LispError("MEMBER: test and test-not both supplied"));
4750            if (testNot == NIL) {
4751                if (test == NIL || test == Symbol.EQL)
4752                    test = EQL;
4753            }
4754            if (key == NIL) {
4755                if (test == EQL) {
4756                    while (tail instanceof Cons) {
4757                        if (item.eql(((Cons)tail).car))
4758                            return tail;
4759                        tail = ((Cons)tail).cdr;
4760                    }
4761                } else if (test != NIL) {
4762                    while (tail instanceof Cons) {
4763                        LispObject candidate = ((Cons)tail).car;
4764                        if (test.execute(item, candidate) != NIL)
4765                            return tail;
4766                        tail = ((Cons)tail).cdr;
4767                    }
4768                } else {
4769                    // test == NIL
4770                    while (tail instanceof Cons) {
4771                        LispObject candidate = ((Cons)tail).car;
4772                        if (testNot.execute(item, candidate) == NIL)
4773                            return tail;
4774                        tail = ((Cons)tail).cdr;
4775                    }
4776                }
4777            } else {
4778                // key != NIL
4779                while (tail instanceof Cons) {
4780                    LispObject candidate = key.execute(((Cons)tail).car);
4781                    if (test != NIL) {
4782                        if (test.execute(item, candidate) != NIL)
4783                            return tail;
4784                    } else {
4785                        if (testNot.execute(item, candidate) == NIL)
4786                            return tail;
4787                    }
4788                    tail = ((Cons)tail).cdr;
4789                }
4790            }
4791            if (tail != NIL)
4792                type_error(tail, Symbol.LIST);
4793            return NIL;
4794        }
4795    };
4796
4797    // ### funcall-key function-or-nil element
4798    private static final Primitive FUNCALL_KEY = new pf_funcall_key();
4799    private static final class pf_funcall_key extends Primitive {
4800        pf_funcall_key() {
4801            super("funcall-key", PACKAGE_SYS, false);
4802        }
4803
4804        @Override
4805        public LispObject execute(LispObject first, LispObject second)
4806
4807        {
4808            if (first != NIL)
4809                return LispThread.currentThread().execute(first, second);
4810            return second;
4811        }
4812    };
4813
4814    // ### coerce-to-function
4815    private static final Primitive COERCE_TO_FUNCTION = new pf_coerce_to_function();
4816    private static final class pf_coerce_to_function extends Primitive {
4817        pf_coerce_to_function() {
4818            super("coerce-to-function", PACKAGE_SYS, true);
4819        }
4820
4821        @Override
4822        public LispObject execute(LispObject arg) {
4823            return coerceToFunction(arg);
4824        }
4825    };
4826
4827    // ### make-closure lambda-form environment => closure
4828    private static final Primitive MAKE_CLOSURE = new pf_make_closure();
4829    private static final class pf_make_closure extends Primitive {
4830        pf_make_closure() {
4831            super("make-closure", PACKAGE_SYS, true);
4832        }
4833
4834        @Override
4835        public LispObject execute(LispObject first, LispObject second)
4836
4837        {
4838            if (first instanceof Cons && ((Cons)first).car == Symbol.LAMBDA) {
4839                final Environment env;
4840                if (second == NIL)
4841                    env = new Environment();
4842                else
4843                    env = checkEnvironment(second);
4844                return new Closure(first, env);
4845            }
4846            return error(new TypeError("The argument to MAKE-CLOSURE is not a lambda form."));
4847        }
4848    };
4849
4850    // ### streamp
4851    private static final Primitive STREAMP = new pf_streamp();
4852    private static final class pf_streamp extends Primitive {
4853        pf_streamp() {
4854            super(Symbol.STREAMP, "object");
4855        }
4856
4857        @Override
4858        public LispObject execute(LispObject arg) {
4859            return arg instanceof Stream ? T : NIL;
4860        }
4861    };
4862
4863    // ### integerp
4864    private static final Primitive INTEGERP = new pf_integerp();
4865    private static final class pf_integerp extends Primitive {
4866        pf_integerp() {
4867            super(Symbol.INTEGERP, "object");
4868        }
4869
4870        @Override
4871        public LispObject execute(LispObject arg) {
4872            return arg.INTEGERP();
4873        }
4874    };
4875
4876    // ### evenp
4877    private static final Primitive EVENP = new pf_evenp();
4878    private static final class pf_evenp extends Primitive {
4879        pf_evenp() {
4880            super(Symbol.EVENP, "integer");
4881        }
4882
4883        @Override
4884        public LispObject execute(LispObject arg) {
4885            return arg.EVENP();
4886        }
4887    };
4888
4889    // ### oddp
4890    private static final Primitive ODDP = new pf_oddp();
4891    private static final class pf_oddp extends Primitive {
4892        pf_oddp() {
4893            super(Symbol.ODDP, "integer");
4894        }
4895
4896        @Override
4897        public LispObject execute(LispObject arg) {
4898            return arg.ODDP();
4899        }
4900    };
4901
4902    // ### numberp
4903    private static final Primitive NUMBERP = new pf_numberp();
4904    private static final class pf_numberp extends Primitive {
4905        pf_numberp() {
4906            super(Symbol.NUMBERP, "object");
4907        }
4908
4909        @Override
4910        public LispObject execute(LispObject arg) {
4911            return arg.NUMBERP();
4912        }
4913    };
4914
4915    // ### realp
4916    private static final Primitive REALP = new pf_realp();
4917    private static final class pf_realp extends Primitive {
4918        pf_realp() {
4919            super(Symbol.REALP, "object");
4920        }
4921
4922        @Override
4923        public LispObject execute(LispObject arg) {
4924            return arg.REALP();
4925        }
4926    };
4927
4928    // ### rationalp
4929    private static final Primitive RATIONALP = new pf_rationalp();
4930    private static final class pf_rationalp extends Primitive {
4931        pf_rationalp() {
4932            super(Symbol.RATIONALP,"object");
4933        }
4934
4935        @Override
4936        public LispObject execute(LispObject arg) {
4937            return arg.RATIONALP();
4938        }
4939    };
4940
4941    // ### complex
4942    private static final Primitive COMPLEX = new pf_complex();
4943    private static final class pf_complex extends Primitive {
4944        pf_complex() {
4945            super(Symbol.COMPLEX, "realpart &optional imagpart");
4946        }
4947
4948        @Override
4949        public LispObject execute(LispObject arg) {
4950            if (arg instanceof SingleFloat)
4951                return Complex.getInstance(arg, SingleFloat.ZERO);
4952            if (arg instanceof DoubleFloat)
4953                return Complex.getInstance(arg, DoubleFloat.ZERO);
4954            if (arg.realp())
4955                return arg;
4956            return type_error(arg, Symbol.REAL);
4957        }
4958        @Override
4959        public LispObject execute(LispObject first, LispObject second)
4960
4961        {
4962            return Complex.getInstance(first, second);
4963        }
4964    };
4965
4966    // ### complexp
4967    private static final Primitive COMPLEXP = new pf_complexp();
4968    private static final class pf_complexp extends Primitive {
4969        pf_complexp() {
4970            super(Symbol.COMPLEXP, "object");
4971        }
4972
4973        @Override
4974        public LispObject execute(LispObject arg) {
4975            return arg.COMPLEXP();
4976        }
4977    };
4978
4979    // ### numerator
4980    private static final Primitive NUMERATOR = new pf_numerator();
4981    private static final class pf_numerator extends Primitive {
4982        pf_numerator() {
4983            super(Symbol.NUMERATOR, "rational");
4984        }
4985
4986        @Override
4987        public LispObject execute(LispObject arg) {
4988            return arg.NUMERATOR();
4989        }
4990    };
4991
4992    // ### denominator
4993    private static final Primitive DENOMINATOR = new pf_denominator();
4994    private static final class pf_denominator extends Primitive {
4995        pf_denominator() {
4996            super(Symbol.DENOMINATOR, "rational");
4997        }
4998
4999        @Override
5000        public LispObject execute(LispObject arg) {
5001            return arg.DENOMINATOR();
5002        }
5003    };
5004
5005    // ### realpart
5006    private static final Primitive REALPART = new pf_realpart();
5007    private static final class pf_realpart extends Primitive {
5008        pf_realpart() {
5009            super(Symbol.REALPART, "number");
5010        }
5011
5012        @Override
5013        public LispObject execute(LispObject arg) {
5014            if (arg instanceof Complex)
5015                return ((Complex)arg).getRealPart();
5016            if (arg.numberp())
5017                return arg;
5018            return type_error(arg, Symbol.NUMBER);
5019        }
5020    };
5021
5022    // ### imagpart
5023    private static final Primitive IMAGPART = new pf_imagpart();
5024    private static final class pf_imagpart extends Primitive {
5025        pf_imagpart() {
5026            super(Symbol.IMAGPART, "number");
5027        }
5028
5029        @Override
5030        public LispObject execute(LispObject arg) {
5031            if (arg instanceof Complex)
5032                return ((Complex)arg).getImaginaryPart();
5033            return arg.multiplyBy(Fixnum.ZERO);
5034        }
5035    };
5036
5037    // ### integer-length
5038    private static final Primitive INTEGER_LENGTH = new pf_integer_length();
5039    private static final class pf_integer_length extends Primitive {
5040        pf_integer_length() {
5041            super(Symbol.INTEGER_LENGTH, "integer");
5042        }
5043
5044        @Override
5045        public LispObject execute(LispObject arg) {
5046            if (arg instanceof Fixnum) {
5047                int n = ((Fixnum)arg).value;
5048                if (n < 0)
5049                    n = ~n;
5050                int count = 0;
5051                while (n > 0) {
5052                    n = n >>> 1;
5053                    ++count;
5054                }
5055                return Fixnum.getInstance(count);
5056            }
5057            if (arg instanceof Bignum)
5058                return Fixnum.getInstance(((Bignum)arg).value.bitLength());
5059            return type_error(arg, Symbol.INTEGER);
5060        }
5061    };
5062
5063    // ### gcd-2
5064    private static final Primitive GCD_2 = new pf_gcd_2();
5065    private static final class pf_gcd_2 extends Primitive {
5066        pf_gcd_2() {
5067            super("gcd-2", PACKAGE_SYS, false);
5068        }
5069
5070        @Override
5071        public LispObject execute(LispObject first, LispObject second)
5072
5073        {
5074            BigInteger n1, n2;
5075            if (first instanceof Fixnum)
5076                n1 = BigInteger.valueOf(((Fixnum)first).value);
5077            else if (first instanceof Bignum)
5078                n1 = ((Bignum)first).value;
5079            else
5080                return type_error(first, Symbol.INTEGER);
5081            if (second instanceof Fixnum)
5082                n2 = BigInteger.valueOf(((Fixnum)second).value);
5083            else if (second instanceof Bignum)
5084                n2 = ((Bignum)second).value;
5085            else
5086                return type_error(second, Symbol.INTEGER);
5087            return number(n1.gcd(n2));
5088        }
5089    };
5090
5091    // ### identity-hash-code
5092    private static final Primitive IDENTITY_HASH_CODE = new pf_identity_hash_code();
5093    private static final class pf_identity_hash_code extends Primitive {
5094        pf_identity_hash_code() {
5095            super("identity-hash-code", PACKAGE_SYS, true);
5096        }
5097
5098        @Override
5099        public LispObject execute(LispObject arg) {
5100            return Fixnum.getInstance(System.identityHashCode(arg));
5101        }
5102    };
5103
5104    // ### simple-vector-search pattern vector => position
5105    // Searches vector for pattern.
5106    private static final Primitive SIMPLE_VECTOR_SEARCH = new pf_simple_vector_search();
5107    private static final class pf_simple_vector_search extends Primitive {
5108        pf_simple_vector_search() {
5109            super("simple-vector-search", PACKAGE_SYS, false);
5110        }
5111
5112        @Override
5113        public LispObject execute(LispObject first, LispObject second)
5114
5115        {
5116            AbstractVector v = checkVector(second);
5117            if (first.length() == 0)
5118                return Fixnum.ZERO;
5119            final int patternLength = first.length();
5120            final int limit = v.length() - patternLength;
5121            if (first instanceof AbstractVector) {
5122                AbstractVector pattern = (AbstractVector) first;
5123                LispObject element = pattern.AREF(0);
5124                for (int i = 0; i <= limit; i++) {
5125                    if (v.AREF(i).eql(element)) {
5126                        // Found match for first element of pattern.
5127                        boolean match = true;
5128                        // We've already checked the first element.
5129                        int j = i + 1;
5130                        for (int k = 1; k < patternLength; k++) {
5131                            if (v.AREF(j).eql(pattern.AREF(k))) {
5132                                ++j;
5133                            } else {
5134                                match = false;
5135                                break;
5136                            }
5137                        }
5138                        if (match)
5139                            return Fixnum.getInstance(i);
5140                    }
5141                }
5142            } else {
5143                // Pattern is a list.
5144                LispObject element = first.car();
5145                for (int i = 0; i <= limit; i++) {
5146                    if (v.AREF(i).eql(element)) {
5147                        // Found match for first element of pattern.
5148                        boolean match = true;
5149                        // We've already checked the first element.
5150                        int j = i + 1;
5151                        for (LispObject rest = first.cdr(); rest != NIL; rest = rest.cdr()) {
5152                            if (v.AREF(j).eql(rest.car())) {
5153                                ++j;
5154                            } else {
5155                                match = false;
5156                                break;
5157                            }
5158                        }
5159                        if (match)
5160                            return Fixnum.getInstance(i);
5161                    }
5162                }
5163            }
5164            return NIL;
5165        }
5166    };
5167
5168    // ### uptime
5169    private static final Primitive UPTIME = new pf_uptime();
5170    private static final class pf_uptime extends Primitive {
5171        pf_uptime() {
5172            super("uptime", PACKAGE_EXT, true);
5173        }
5174
5175        @Override
5176        public LispObject execute() {
5177            return number(System.currentTimeMillis() - Main.startTimeMillis);
5178        }
5179    };
5180
5181    // ### built-in-function-p
5182    private static final Primitive BUILT_IN_FUNCTION_P = new pf_built_in_function_p();
5183    private static final class pf_built_in_function_p extends Primitive {
5184        pf_built_in_function_p() {
5185            super("built-in-function-p", PACKAGE_SYS, true);
5186        }
5187
5188        @Override
5189        public LispObject execute(LispObject arg) {
5190            return checkSymbol(arg).isBuiltInFunction() ? T : NIL;
5191        }
5192    };
5193
5194    // ### inspected-parts
5195    private static final Primitive INSPECTED_PARTS = new pf_inspected_parts();
5196    private static final class pf_inspected_parts extends Primitive {
5197        pf_inspected_parts() {
5198            super("inspected-parts", PACKAGE_SYS, true);
5199        }
5200
5201        @Override
5202        public LispObject execute(LispObject arg) {
5203            return arg.getParts();
5204        }
5205    };
5206
5207    // ### inspected-description
5208    private static final Primitive INSPECTED_DESCRIPTION = new pf_inspected_description();
5209    private static final class pf_inspected_description extends Primitive {
5210        pf_inspected_description() {
5211            super("inspected-description", PACKAGE_SYS, false);
5212        }
5213
5214        @Override
5215        public LispObject execute(LispObject arg) {
5216            return arg.getDescription();
5217        }
5218    };
5219
5220    // ### symbol-name
5221    public static final Primitive SYMBOL_NAME = new pf_symbol_name();
5222    private static final class pf_symbol_name extends Primitive {
5223        pf_symbol_name() {
5224            super(Symbol.SYMBOL_NAME, "symbol");
5225        }
5226
5227        @Override
5228        public LispObject execute(LispObject arg) {
5229            return checkSymbol(arg).name;
5230        }
5231    };
5232
5233    // ### symbol-package
5234    public static final Primitive SYMBOL_PACKAGE = new pf_symbol_package();
5235    private static final class pf_symbol_package extends Primitive {
5236        pf_symbol_package() {
5237            super(Symbol.SYMBOL_PACKAGE, "symbol");
5238        }
5239
5240        @Override
5241        public LispObject execute(LispObject arg) {
5242            return checkSymbol(arg).getPackage();
5243        }
5244    };
5245
5246    // ### symbol-function
5247    public static final Primitive SYMBOL_FUNCTION = new pf_symbol_function();
5248    private static final class pf_symbol_function extends Primitive {
5249        pf_symbol_function() {
5250            super(Symbol.SYMBOL_FUNCTION, "symbol");
5251        }
5252
5253        @Override
5254        public LispObject execute(LispObject arg) {
5255            LispObject function = checkSymbol(arg).getSymbolFunction();
5256            if (function != null)
5257                return function;
5258            return error(new UndefinedFunction(arg));
5259
5260        }
5261    };
5262
5263    // ### %set-symbol-function
5264    public static final Primitive _SET_SYMBOL_FUNCTION = new pf__set_symbol_function();
5265    private static final class pf__set_symbol_function extends Primitive {
5266        pf__set_symbol_function() {
5267            super("%set-symbol-function", PACKAGE_SYS, false, "symbol function");
5268        }
5269
5270        @Override
5271        public LispObject execute(LispObject first, LispObject second)
5272
5273        {
5274            checkSymbol(first).setSymbolFunction(second);
5275            return second;
5276        }
5277    };
5278
5279    // ### symbol-plist
5280    public static final Primitive SYMBOL_PLIST = new pf_symbol_plist();
5281    private static final class pf_symbol_plist extends Primitive {
5282        pf_symbol_plist() {
5283            super(Symbol.SYMBOL_PLIST, "symbol");
5284        }
5285
5286        @Override
5287        public LispObject execute(LispObject arg) {
5288            return checkSymbol(arg).getPropertyList();
5289        }
5290    };
5291
5292    // ### keywordp
5293    public static final Primitive KEYWORDP = new pf_keywordp();
5294    private static final class pf_keywordp extends Primitive {
5295        pf_keywordp() {
5296            super(Symbol.KEYWORDP, "object");
5297        }
5298
5299        @Override
5300        public LispObject execute(LispObject arg) {
5301            if (arg instanceof Symbol) {
5302                if (checkSymbol(arg).getPackage() == PACKAGE_KEYWORD)
5303                    return T;
5304            }
5305            return NIL;
5306        }
5307    };
5308
5309    // ### make-symbol
5310    public static final Primitive MAKE_SYMBOL = new pf_make_symbol();
5311    private static final class pf_make_symbol extends Primitive {
5312        pf_make_symbol() {
5313            super(Symbol.MAKE_SYMBOL, "name");
5314        }
5315
5316        @Override
5317        public LispObject execute(LispObject arg) {
5318            if (arg instanceof SimpleString)
5319                return new Symbol((SimpleString)arg);
5320            // Not a simple string.
5321            if (arg instanceof AbstractString)
5322                return new Symbol(arg.getStringValue());
5323            return type_error(arg, Symbol.STRING);
5324        }
5325    };
5326
5327    // ### makunbound
5328    public static final Primitive MAKUNBOUND = new pf_makunbound();
5329    private static final class pf_makunbound extends Primitive {
5330        pf_makunbound() {
5331            super(Symbol.MAKUNBOUND, "symbol");
5332        }
5333
5334        @Override
5335        public LispObject execute(LispObject arg) {
5336            checkSymbol(arg).setSymbolValue(null);
5337            return arg;
5338        }
5339    };
5340
5341    // ### %class-name
5342    private static final Primitive _CLASS_NAME = new pf__class_name();
5343    private static final class pf__class_name extends Primitive {
5344        pf__class_name() {
5345            super("%class-name", PACKAGE_SYS, true, "class");
5346        }
5347
5348        @Override
5349        public LispObject execute(LispObject arg) {
5350            if (arg instanceof LispClass)
5351                return ((LispClass)arg).getName();
5352
5353            return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symName);
5354        }
5355    };
5356
5357    // ### %set-class-name
5358    private static final Primitive _SET_CLASS_NAME = new pf__set_class_name();
5359    private static final class pf__set_class_name extends Primitive {
5360        pf__set_class_name() {
5361            super("%set-class-name", PACKAGE_SYS, true);
5362        }
5363
5364        @Override
5365        public LispObject execute(LispObject first, LispObject second)
5366
5367        {
5368            if (second instanceof LispClass)
5369                ((LispClass)second).setName(checkSymbol(first));
5370            else
5371                ((StandardObject)second).setInstanceSlotValue(StandardClass.symName,
5372                                                           checkSymbol(first));
5373            return first;
5374        }
5375    };
5376
5377    // ### class-layout
5378    private static final Primitive CLASS_LAYOUT = new pf__class_layout();
5379    private static final class pf__class_layout extends Primitive {
5380        pf__class_layout() {
5381            super("%class-layout", PACKAGE_SYS, true, "class");
5382        }
5383
5384        @Override
5385        public LispObject execute(LispObject arg) {
5386            Layout layout;
5387            if (arg instanceof LispClass)
5388              layout = ((LispClass)arg).getClassLayout();
5389            else
5390              layout = (Layout)((StandardObject)arg).getInstanceSlotValue(StandardClass.symLayout);
5391
5392            return layout != null ? layout : NIL;
5393        }
5394    };
5395
5396    // ### %set-class-layout
5397    private static final Primitive _SET_CLASS_LAYOUT = new pf__set_class_layout();
5398    private static final class pf__set_class_layout extends Primitive {
5399        pf__set_class_layout() {
5400            super("%set-class-layout", PACKAGE_SYS, true, "class layout");
5401        }
5402
5403        @Override
5404        public LispObject execute(LispObject first, LispObject second)
5405
5406        {
5407            if (first == NIL || first instanceof Layout) {
5408                if (second instanceof LispClass)
5409                  ((LispClass)second).setClassLayout(first);
5410                else
5411                  ((StandardObject)second).setInstanceSlotValue(StandardClass.symLayout, first);
5412                return first;
5413            }
5414            return type_error(first, Symbol.LAYOUT);
5415        }
5416    };
5417
5418    // ### %class-direct-superclasses
5419    private static final Primitive _CLASS_DIRECT_SUPERCLASSES = new pf__class_direct_superclasses();
5420    private static final class pf__class_direct_superclasses extends Primitive {
5421        pf__class_direct_superclasses() {
5422            super("%class-direct-superclasses", PACKAGE_SYS, true);
5423        }
5424
5425        @Override
5426        public LispObject execute(LispObject arg) {
5427            if (arg instanceof LispClass)
5428              return ((LispClass)arg).getDirectSuperclasses();
5429            else
5430              return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSuperclasses);
5431        }
5432    };
5433
5434    // ### %set-class-direct-superclasses
5435    private static final Primitive _SET_CLASS_DIRECT_SUPERCLASSES = new pf__set_class_direct_superclasses();
5436    private static final class pf__set_class_direct_superclasses extends Primitive {
5437        pf__set_class_direct_superclasses() {
5438            super("%set-class-direct-superclasses", PACKAGE_SYS, true);
5439        }
5440
5441        @Override
5442        public LispObject execute(LispObject first, LispObject second)
5443        {
5444            if (second instanceof LispClass)
5445              ((LispClass)second).setDirectSuperclasses(first);
5446            else
5447              ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectSuperclasses, first);
5448            return first;
5449        }
5450    };
5451
5452    // ### %class-direct-subclasses
5453    private static final Primitive _CLASS_DIRECT_SUBCLASSES = new pf__class_direct_subclasses();
5454    private static final class pf__class_direct_subclasses extends Primitive {
5455        pf__class_direct_subclasses() {
5456            super("%class-direct-subclasses", PACKAGE_SYS, true);
5457        }
5458
5459        @Override
5460        public LispObject execute(LispObject arg) {
5461            if (arg instanceof LispClass)
5462                return ((LispClass)arg).getDirectSubclasses();
5463            else
5464                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSubclasses);
5465        }
5466    };
5467
5468    // ### %set-class-direct-subclasses
5469    private static final Primitive _SET_CLASS_DIRECT_SUBCLASSES = new pf__set_class_direct_subclasses();
5470    private static final class pf__set_class_direct_subclasses extends Primitive {
5471        pf__set_class_direct_subclasses() {
5472            super("%set-class-direct-subclasses", PACKAGE_SYS, true,
5473                  "class direct-subclasses");
5474        }
5475
5476        @Override
5477        public LispObject execute(LispObject first, LispObject second)
5478        {
5479            if (second instanceof LispClass)
5480                ((LispClass)second).setDirectSubclasses(first);
5481            else
5482                ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectSubclasses, first);
5483            return first;
5484        }
5485    };
5486
5487    // ### %class-precedence-list
5488    private static final Primitive _CLASS_PRECEDENCE_LIST = new pf__class_precedence_list();
5489    private static final class pf__class_precedence_list extends Primitive {
5490        pf__class_precedence_list() {
5491            super("%class-precedence-list", PACKAGE_SYS, true);
5492        }
5493
5494        @Override
5495        public LispObject execute(LispObject arg) {
5496            if (arg instanceof LispClass)
5497                return ((LispClass)arg).getCPL();
5498            else
5499                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symPrecedenceList);
5500        }
5501    };
5502
5503    // ### %set-class-precedence-list
5504    private static final Primitive _SET_CLASS_PRECEDENCE_LIST = new pf__set_class_precedence_list();
5505    private static final class pf__set_class_precedence_list extends Primitive {
5506        pf__set_class_precedence_list() {
5507            super("%set-class-precedence-list", PACKAGE_SYS, true);
5508        }
5509
5510        @Override
5511        public LispObject execute(LispObject first, LispObject second)
5512        {
5513            if (second instanceof LispClass)
5514                ((LispClass)second).setCPL(first);
5515            else
5516                ((StandardObject)second).setInstanceSlotValue(StandardClass.symPrecedenceList, first);
5517            return first;
5518        }
5519    };
5520
5521    // ### %class-direct-methods
5522    private static final Primitive _CLASS_DIRECT_METHODS = new pf__class_direct_methods();
5523    private static final class pf__class_direct_methods extends Primitive {
5524        pf__class_direct_methods() {
5525            super("%class-direct-methods", PACKAGE_SYS, true);
5526        }
5527
5528        @Override
5529        public LispObject execute(LispObject arg)
5530        {
5531            if (arg instanceof LispClass)
5532                return ((LispClass)arg).getDirectMethods();
5533            else
5534                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectMethods);
5535        }
5536    };
5537
5538    // ### %set-class-direct-methods
5539    private static final Primitive _SET_CLASS_DIRECT_METHODS = new pf__set_class_direct_methods();
5540    private static final class pf__set_class_direct_methods extends Primitive {
5541        pf__set_class_direct_methods() {
5542            super("%set-class-direct-methods", PACKAGE_SYS, true);
5543        }
5544
5545        @Override
5546        public LispObject execute(LispObject first, LispObject second)
5547        {
5548            if (second instanceof LispClass)
5549                ((LispClass)second).setDirectMethods(first);
5550            else
5551                ((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectMethods, first);
5552            return first;
5553        }
5554    };
5555
5556    // ### class-documentation
5557    private static final Primitive CLASS_DOCUMENTATION
5558        = new pf_class_documentation();
5559    private static final class pf_class_documentation extends Primitive {
5560        pf_class_documentation() {
5561            super("class-documentation", PACKAGE_MOP, true);
5562        }
5563
5564        @Override
5565        public LispObject execute(LispObject arg)
5566
5567        {
5568            if (arg instanceof LispClass)
5569                return ((LispClass)arg).getDocumentation();
5570            else
5571                return ((StandardObject)arg).getInstanceSlotValue(Symbol._DOCUMENTATION);
5572        }
5573    };
5574
5575    // ### %set-class-documentation
5576    private static final Primitive _SET_CLASS_DOCUMENTATION
5577        = new pf__set_class_documentation();
5578    private static final class pf__set_class_documentation extends Primitive {
5579        pf__set_class_documentation() {
5580            super("%set-class-documentation", PACKAGE_SYS, true);
5581        }
5582
5583        @Override
5584        public LispObject execute(LispObject first, LispObject second)
5585        {
5586            if (first instanceof LispClass)
5587                ((LispClass)first).setDocumentation(second);
5588            else
5589                ((StandardObject)first).setInstanceSlotValue(Symbol._DOCUMENTATION, second);
5590            return second;
5591        }
5592    };
5593
5594    // ### %class-finalized-p
5595    private static final Primitive _CLASS_FINALIZED_P = new pf__class_finalized_p();
5596    private static final class pf__class_finalized_p extends Primitive {
5597        pf__class_finalized_p() {
5598            super("%class-finalized-p", PACKAGE_SYS, true);
5599        }
5600
5601        @Override
5602        public LispObject execute(LispObject arg) {
5603            if (arg instanceof LispClass)
5604                return ((LispClass)arg).isFinalized() ? T : NIL;
5605            else
5606                return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symFinalizedP);
5607        }
5608    };
5609
5610    // ### %set-class-finalized-p
5611    private static final Primitive _SET_CLASS_FINALIZED_P = new pf__set_class_finalized_p();
5612    private static final class pf__set_class_finalized_p extends Primitive {
5613        pf__set_class_finalized_p() {
5614            super("%set-class-finalized-p", PACKAGE_SYS, true);
5615        }
5616
5617        @Override
5618        public LispObject execute(LispObject first, LispObject second)
5619        {
5620            if (second instanceof LispClass)
5621                ((LispClass)second).setFinalized(first != NIL);
5622            else
5623                ((StandardObject)second).setInstanceSlotValue(StandardClass.symFinalizedP, first);
5624            return first;
5625        }
5626    };
5627
5628    // ### classp
5629    private static final Primitive CLASSP = new pf_classp();
5630    private static final class pf_classp extends Primitive {
5631        pf_classp() {
5632            super("classp", PACKAGE_EXT, true);
5633        }
5634
5635        @Override
5636        public LispObject execute(LispObject arg) {
5637            return (arg instanceof LispClass) ? T : arg.typep(Symbol.CLASS);
5638        }
5639    };
5640
5641    // ### char-to-utf8 char => octets
5642    private static final Primitive CHAR_TO_UTF8 = new pf_char_to_utf8();
5643    private static final class pf_char_to_utf8 extends Primitive {
5644        pf_char_to_utf8() {
5645            super("char-to-utf8", PACKAGE_EXT, true);
5646        }
5647
5648        @Override
5649        public LispObject execute(LispObject arg) {
5650            final LispCharacter c;
5651            c = checkCharacter( arg);
5652            char[] chars = new char[1];
5653            chars[0] = c.value;
5654            String s = new String(chars);
5655            final byte[] bytes;
5656            try {
5657                bytes = s.getBytes("UTF8");
5658            } catch (java.io.UnsupportedEncodingException e) {
5659                return error(new LispError("UTF8 is not a supported encoding."));
5660            }
5661            LispObject[] objects = new LispObject[bytes.length];
5662            for (int i = bytes.length; i-- > 0;) {
5663                int n = bytes[i];
5664                if (n < 0)
5665                    n += 256;
5666                objects[i] = Fixnum.getInstance(n);
5667            }
5668            return new SimpleVector(objects);
5669        }
5670    };
5671
5672    // ### %documentation
5673    private static final Primitive _DOCUMENTATION = new pf__documentation();
5674    private static final class pf__documentation extends Primitive {
5675        pf__documentation() {
5676            super("%documentation", PACKAGE_SYS, true,
5677                  "object doc-type");
5678        }
5679
5680        @Override
5681        public LispObject execute(LispObject object, LispObject docType)
5682
5683        {
5684            LispObject doc = object.getDocumentation(docType);
5685            if (doc == NIL) {
5686                if (docType == Symbol.FUNCTION && object instanceof Symbol) {
5687                    // Generic functions are handled at lisp-level, not here
5688                    LispObject function = object.getSymbolFunction();
5689                    if (function != null)
5690                        doc = function.getDocumentation(docType);
5691                }
5692            }
5693            return doc;
5694        }
5695    };
5696
5697    // ### %set-documentation
5698    private static final Primitive _SET_DOCUMENTATION = new pf__set_documentation();
5699    private static final class pf__set_documentation extends Primitive {
5700        pf__set_documentation() {
5701            super("%set-documentation", PACKAGE_SYS, true,
5702                  "object doc-type documentation");
5703        }
5704
5705        @Override
5706        public LispObject execute(LispObject object, LispObject docType,
5707                                  LispObject documentation)
5708
5709        {
5710            // Generic functions are handled at lisp-level, not here
5711            object.setDocumentation(docType, documentation);
5712            return documentation;
5713        }
5714    };
5715
5716    // ### %putf
5717    private static final Primitive _PUTF = new pf__putf();
5718    private static final class pf__putf extends Primitive {
5719        pf__putf() {
5720            super("%putf", PACKAGE_SYS, true,
5721                  "plist indicator new-value");
5722        }
5723
5724        @Override
5725        public LispObject execute(LispObject plist, LispObject indicator,
5726                                  LispObject newValue)
5727
5728        {
5729            return putf(plist, indicator, newValue);
5730        }
5731    };
5732
5733    // ### function-plist
5734    private static final Primitive FUNCTION_PLIST = new pf_function_plist();
5735    private static final class pf_function_plist extends Primitive {
5736        pf_function_plist() {
5737            super("function-plist", PACKAGE_SYS, true, "function");
5738        }
5739
5740        @Override
5741        public LispObject execute(LispObject arg) {
5742            return checkFunction(arg).getPropertyList();
5743        }
5744    };
5745
5746    // ### make-keyword
5747    private static final Primitive MAKE_KEYWORD = new pf_make_keyword();
5748    private static final class pf_make_keyword extends Primitive {
5749        pf_make_keyword() {
5750            super("make-keyword", PACKAGE_SYS, true, "symbol");
5751        }
5752
5753        @Override
5754        public LispObject execute(LispObject arg) {
5755            return PACKAGE_KEYWORD.intern(checkSymbol(arg).name);
5756        }
5757    };
5758
5759    // ### standard-object-p object => generalized-boolean
5760    private static final Primitive STANDARD_OBJECT_P = new pf_standard_object_p();
5761    private static final class pf_standard_object_p extends Primitive {
5762        pf_standard_object_p() {
5763            super("standard-object-p", PACKAGE_SYS, true, "object");
5764        }
5765
5766        @Override
5767        public LispObject execute(LispObject arg) {
5768            return arg instanceof StandardObject ? T : NIL;
5769        }
5770    };
5771
5772    // ### copy-tree
5773    private static final Primitive COPY_TREE = new pf_copy_tree();
5774    private static final class pf_copy_tree extends Primitive {
5775        pf_copy_tree() {
5776            super(Symbol.COPY_TREE, "object");
5777        }
5778
5779        @Override
5780        public LispObject execute(LispObject arg) {
5781            if (arg instanceof Cons) {
5782                Cons cons = (Cons) arg;
5783                return new Cons(execute(cons.car), execute(cons.cdr));
5784            } else
5785                return arg;
5786        }
5787    };
5788
5789    /* Added to ABCL because Maxima wants to be able to turn off
5790     * underflow conditions. However, the Hyperspec says we have to
5791     * signal them. So, we went for CLHS compliant with a switch for
5792     * Maxima.
5793     */
5794    // ### float-underflow-mode
5795    private static final Primitive FLOAT_UNDERFLOW_MODE
5796        = new pf_float_underflow_mode();
5797    private static final class pf_float_underflow_mode extends Primitive {
5798        pf_float_underflow_mode() {
5799            super(Symbol.FLOAT_UNDERFLOW_MODE, "&optional boolean");
5800        }
5801
5802        @Override
5803        public LispObject execute() {
5804            return Lisp.TRAP_UNDERFLOW ? T : NIL;
5805        }
5806
5807        @Override
5808        public LispObject execute(LispObject arg) {
5809            Lisp.TRAP_UNDERFLOW = (arg != NIL);
5810            return arg;
5811        }
5812    };
5813
5814    /* Implemented for symmetry with the underflow variant. */
5815    // ### float-overflow-mode
5816    private static final Primitive FLOAT_OVERFLOW_MODE
5817        = new pf_float_overflow_mode();
5818    private static final class pf_float_overflow_mode extends Primitive {
5819        pf_float_overflow_mode() {
5820            super(Symbol.FLOAT_OVERFLOW_MODE, "&optional boolean");
5821        }
5822
5823        @Override
5824        public LispObject execute() {
5825            return Lisp.TRAP_OVERFLOW ? T : NIL;
5826        }
5827
5828        @Override
5829        public LispObject execute(LispObject arg) {
5830            Lisp.TRAP_OVERFLOW = (arg != NIL);
5831            return arg;
5832        }
5833    };
5834
5835    // ### finalize
5836    private static final Primitive FINALIZE
5837        = new pf_finalize();
5838    private static final class pf_finalize extends Primitive {
5839        pf_finalize() {
5840            super("finalize", PACKAGE_EXT, true, "object function");
5841        }
5842
5843        @Override
5844        public LispObject execute(LispObject obj, final LispObject fun) {
5845            Finalizer.addFinalizer(obj, new Runnable() {
5846                @Override
5847                public void run() {
5848                    fun.execute();
5849                }
5850            });
5851            return obj;
5852        }
5853    };
5854
5855    // ### cancel-finalization
5856    private static final Primitive CANCEL_FINALIZATION
5857        = new pf_cancel_finalization();
5858    private static final class pf_cancel_finalization extends Primitive {
5859        pf_cancel_finalization() {
5860            super("cancel-finalization", PACKAGE_EXT, true, "object");
5861        }
5862
5863        @Override
5864        public LispObject execute(LispObject obj) {
5865            Finalizer.clearFinalizers(obj);
5866            return obj;
5867        }
5868    };
5869
5870    private static final Primitive GET_FASL_READTABLE
5871            = new pf_get_fasl_readtable();
5872    private static class pf_get_fasl_readtable extends Primitive {
5873        pf_get_fasl_readtable() {
5874            super("get-fasl-readtable", PACKAGE_SYS, false);
5875        }
5876       
5877        @Override
5878        public LispObject execute() {
5879            return FaslReadtable.getInstance();
5880        }
5881    }
5882   
5883}
Note: See TracBrowser for help on using the repository browser.