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

Last change on this file was 13168, checked in by ehuelsmann, 15 years ago

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