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

Last change on this file was 13250, checked in by ehuelsmann, 14 years ago

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