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

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

Fix #161: READTABLE-CASE setting of *readtable* affects FASL content.

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