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

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

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