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

Last change on this file was 12809, checked in by Mark Evenson, 15 years ago

Honor *PRINT-READABLY* by throwing PRINT-NOT-READABLE for "#<".

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