|
1
21
22 package org.armedbear.lisp;
23
24 import java.io.File  ;
25 import java.math.BigInteger ;
26 import java.util.ArrayList ;
27
28 public final class Primitives extends Lisp
29 {
30 public static final Primitive MULTIPLY = new Primitive("*","&rest numbers")
32 {
33 public LispObject execute()
34 {
35 return Fixnum.ONE;
36 }
37 public LispObject execute(LispObject arg) throws ConditionThrowable
38 {
39 if (arg.numberp())
40 return arg;
41 signal(new TypeError(arg, "number"));
42 return NIL;
43 }
44 public LispObject execute(LispObject first, LispObject second)
45 throws ConditionThrowable
46 {
47 return first.multiplyBy(second);
48 }
49 public LispObject execute(LispObject[] args) throws ConditionThrowable
50 {
51 LispObject result = Fixnum.ONE;
52 for (int i = 0; i < args.length; i++)
53 result = result.multiplyBy(args[i]);
54 return result;
55 }
56 };
57
58 public static final Primitive DIVIDE = new Primitive("/","numerator &rest denominators")
60 {
61 public LispObject execute() throws ConditionThrowable
62 {
63 signal(new WrongNumberOfArgumentsException("/"));
64 return NIL;
65 }
66 public LispObject execute(LispObject arg) throws ConditionThrowable
67 {
68 return Fixnum.ONE.divideBy(arg);
69 }
70 public LispObject execute(LispObject first, LispObject second)
71 throws ConditionThrowable
72 {
73 return first.divideBy(second);
74 }
75 public LispObject execute(LispObject[] args) throws ConditionThrowable
76 {
77 LispObject result = args[0];
78 for (int i = 1; i < args.length; i++)
79 result = result.divideBy(args[i]);
80 return result;
81 }
82 };
83
84 public static final Primitive MIN = new Primitive("min","&rest reals")
86 {
87 public LispObject execute() throws ConditionThrowable
88 {
89 signal(new WrongNumberOfArgumentsException("min"));
90 return NIL;
91 }
92 public LispObject execute(LispObject arg) throws ConditionThrowable
93 {
94 if (arg.realp())
95 return arg;
96 signal(new TypeError(arg, "real number"));
97 return NIL;
98 }
99 public LispObject execute(LispObject[] args) throws ConditionThrowable
100 {
101 LispObject result = args[0];
102 if (!result.realp())
103 signal(new TypeError(result, "real number"));
104 for (int i = 1; i < args.length; i++) {
105 if (args[i].isLessThan(result))
106 result = args[i];
107 }
108 return result;
109 }
110 };
111
112
113 public static final Primitive MAX = new Primitive("max","&rest reals")
115 {
116 public LispObject execute() throws ConditionThrowable
117 {
118 signal(new WrongNumberOfArgumentsException("max"));
119 return NIL;
120 }
121 public LispObject execute(LispObject arg) throws ConditionThrowable
122 {
123 if (arg.realp())
124 return arg;
125 signal(new TypeError(arg, "real number"));
126 return NIL;
127 }
128 public LispObject execute(LispObject[] args) throws ConditionThrowable
129 {
130 LispObject result = args[0];
131 if (!result.realp())
132 signal(new TypeError(result, "real number"));
133 for (int i = 1; i < args.length; i++) {
134 if (args[i].isGreaterThan(result))
135 result = args[i];
136 }
137 return result;
138 }
139 };
140
141 private static final Primitive1 IDENTITY = new Primitive1("identity","object")
143 {
144 public LispObject execute(LispObject arg) throws ConditionThrowable
145 {
146 return arg;
147 }
148 };
149
150 private static final Primitive1 COMPILED_FUNCTION_P =
152 new Primitive1("compiled-function-p","object")
153 {
154 public LispObject execute(LispObject arg) throws ConditionThrowable
155 {
156 return arg.typep(Symbol.COMPILED_FUNCTION);
157 }
158 };
159
160 private static final Primitive1 CONSP = new Primitive1("consp","object")
162 {
163 public LispObject execute(LispObject arg) throws ConditionThrowable
164 {
165 return arg instanceof Cons ? T : NIL;
166 }
167 };
168
169 private static final Primitive1 LISTP = new Primitive1("listp","object")
171 {
172 public LispObject execute(LispObject arg) throws ConditionThrowable
173 {
174 return arg.LISTP();
175 }
176 };
177
178 private static final Primitive1 ABS = new Primitive1("abs","number")
180 {
181 public LispObject execute(LispObject arg) throws ConditionThrowable
182 {
183 return arg.ABS();
184 }
185 };
186
187 private static final Primitive1 ARRAYP = new Primitive1("arrayp","object")
189 {
190 public LispObject execute(LispObject arg) throws ConditionThrowable
191 {
192 return arg instanceof AbstractArray ? T : NIL;
193 }
194 };
195
196 private static final Primitive1 ARRAY_HAS_FILL_POINTER_P =
198 new Primitive1("array-has-fill-pointer-p", "array")
199 {
200 public LispObject execute(LispObject arg) throws ConditionThrowable
201 {
202 try {
203 return ((AbstractArray)arg).hasFillPointer() ? T : NIL;
204 }
205 catch (ClassCastException e) {
206 return signal(new TypeError(arg, Symbol.ARRAY));
207 }
208 }
209 };
210
211 private static final Primitive1 VECTORP = new Primitive1("vectorp", "object")
213 {
214 public LispObject execute(LispObject arg) throws ConditionThrowable
215 {
216 return arg.VECTORP();
217 }
218 };
219
220 private static final Primitive1 SIMPLE_VECTOR_P =
222 new Primitive1("simple-vector-p", "object")
223 {
224 public LispObject execute(LispObject arg) throws ConditionThrowable
225 {
226 return arg instanceof SimpleVector ? T : NIL;
227 }
228 };
229
230 private static final Primitive1 BIT_VECTOR_P =
232 new Primitive1("bit-vector-p", "object")
233 {
234 public LispObject execute(LispObject arg) throws ConditionThrowable
235 {
236 return arg.BIT_VECTOR_P();
237 }
238 };
239
240 private static final Primitive1 SIMPLE_BIT_VECTOR_P =
242 new Primitive1("simple-bit-vector-p", "object")
243 {
244 public LispObject execute(LispObject arg) throws ConditionThrowable
245 {
246 return arg.typep(Symbol.SIMPLE_BIT_VECTOR);
247 }
248 };
249
250 private static final Primitive1 _EVAL =
252 new Primitive1("%eval", PACKAGE_SYS, false, "form")
253 {
254 public LispObject execute(LispObject arg) throws ConditionThrowable
255 {
256 return eval(arg, new Environment(), LispThread.currentThread());
257 }
258 };
259
260 private static final Primitive2 EQ = new Primitive2("eq", "x y")
262 {
263 public LispObject execute(LispObject first, LispObject second)
264 throws ConditionThrowable
265 {
266 return first == second ? T : NIL;
267 }
268 };
269
270 private static final Primitive2 EQL = new Primitive2("eql", "x y")
272 {
273 public LispObject execute(LispObject first, LispObject second)
274 throws ConditionThrowable
275 {
276 return first.eql(second) ? T : NIL;
277 }
278 };
279
280 private static final Primitive2 EQUAL = new Primitive2("equal", "x y")
282 {
283 public LispObject execute(LispObject first, LispObject second)
284 throws ConditionThrowable
285 {
286 return first.equal(second) ? T : NIL;
287 }
288 };
289
290 private static final Primitive2 EQUALP = new Primitive2("equalp", "x y")
292 {
293 public LispObject execute(LispObject first, LispObject second)
294 throws ConditionThrowable
295 {
296 return first.equalp(second) ? T : NIL;
297 }
298 };
299
300 private static final Primitive VALUES = new Primitive("values", "&rest object")
302 {
303 public LispObject execute()
304 throws ConditionThrowable
305 {
306 return LispThread.currentThread().setValues();
307 }
308 public LispObject execute(LispObject arg)
309 throws ConditionThrowable
310 {
311 return LispThread.currentThread().setValues(arg);
312 }
313 public LispObject execute(LispObject first, LispObject second)
314 throws ConditionThrowable
315 {
316 return LispThread.currentThread().setValues(first, second);
317 }
318 public LispObject execute(LispObject first, LispObject second,
319 LispObject third)
320 throws ConditionThrowable
321 {
322 return LispThread.currentThread().setValues(first, second, third);
323 }
324 public LispObject execute(LispObject[] args)
325 throws ConditionThrowable
326 {
327 return LispThread.currentThread().setValues(args);
328 }
329 };
330
331 private static final Primitive1 VALUES_LIST =
335 new Primitive1("values-list", "list")
336 {
337 public LispObject execute(LispObject arg) throws ConditionThrowable
338 {
339 return LispThread.currentThread().setValues(arg.copyToArray());
340 }
341 };
342
343 private static final Primitive2 CONS =
345 new Primitive2("cons", "object-1 object-2")
346 {
347 public LispObject execute(LispObject first, LispObject second)
348 throws ConditionThrowable
349 {
350 return new Cons(first, second);
351 }
352 };
353
354 private static final Primitive1 LENGTH =
356 new Primitive1("length", "sequence")
357 {
358 public LispObject execute(LispObject arg) throws ConditionThrowable
359 {
360 return arg.LENGTH();
361 }
362 };
363
364 private static final Primitive2 ELT =
366 new Primitive2("elt", "sequence index")
367 {
368 public LispObject execute(LispObject first, LispObject second)
369 throws ConditionThrowable
370 {
371 try {
372 return first.elt(((Fixnum)second).value);
373 }
374 catch (ClassCastException e) {
375 return signal(new TypeError(second, Symbol.FIXNUM));
376 }
377 }
378 };
379
380 private static final Primitive1 ATOM = new Primitive1("atom", "object")
382 {
383 public LispObject execute(LispObject arg) throws ConditionThrowable
384 {
385 return arg instanceof Cons ? NIL : T;
386 }
387 };
388
389 private static final Primitive CONSTANTP =
391 new Primitive("constantp", "form &optional environment")
392 {
393 public LispObject execute(LispObject arg) throws ConditionThrowable
394 {
395 return arg.constantp() ? T : NIL;
396 }
397 public LispObject execute(LispObject first, LispObject second)
398 throws ConditionThrowable
399 {
400 return first.constantp() ? T : NIL;
401 }
402 };
403
404 private static final Primitive1 FUNCTIONP = new Primitive1("functionp","object")
406 {
407 public LispObject execute(LispObject arg) throws ConditionThrowable
408 {
409 return (arg instanceof Function || arg instanceof GenericFunction) ? T : NIL;
410 }
411 };
412
413 private static final Primitive1 SPECIAL_OPERATOR_P =
415 new Primitive1("special-operator-p","symbol")
416 {
417 public LispObject execute(LispObject arg) throws ConditionThrowable
418 {
419 return arg.getSymbolFunction() instanceof SpecialOperator ? T : NIL;
420 }
421 };
422
423 private static final Primitive1 SYMBOLP = new Primitive1("symbolp", "object")
425 {
426 public LispObject execute(LispObject arg) throws ConditionThrowable
427 {
428 return arg instanceof Symbol ? T : NIL;
429 }
430 };
431
432 private static final Primitive1 ENDP = new Primitive1("endp", "list")
434 {
435 public LispObject execute(LispObject arg) throws ConditionThrowable
436 {
437 return arg.endp() ? T : NIL;
438 }
439 };
440
441 private static final Primitive1 NULL = new Primitive1("null", "object")
443 {
444 public LispObject execute(LispObject arg) throws ConditionThrowable
445 {
446 return arg == NIL ? T : NIL;
447 }
448 };
449
450 private static final Primitive1 NOT = new Primitive1("not", "x")
452 {
453 public LispObject execute(LispObject arg) throws ConditionThrowable
454 {
455 return arg == NIL ? T : NIL;
456 }
457 };
458
459 private static final Primitive1 PLUSP = new Primitive1("plusp", "real")
461 {
462 public LispObject execute(LispObject arg) throws ConditionThrowable
463 {
464 return arg.PLUSP();
465 }
466 };
467
468 private static final Primitive1 MINUSP = new Primitive1("minusp", "real")
470 {
471 public LispObject execute(LispObject arg) throws ConditionThrowable
472 {
473 return arg.MINUSP();
474 }
475 };
476
477 private static final Primitive1 ZEROP = new Primitive1("zerop","number") {
479 public LispObject execute(LispObject arg) throws ConditionThrowable
480 {
481 return arg.ZEROP();
482 }
483 };
484
485 private static final Primitive1 FIXNUMP =
487 new Primitive1("fixnump", PACKAGE_EXT, true) {
488 public LispObject execute(LispObject arg) throws ConditionThrowable
489 {
490 return arg instanceof Fixnum ? T : NIL;
491 }
492 };
493
494 private static final Primitive1 SYMBOL_VALUE =
496 new Primitive1("symbol-value", "symbol")
497 {
498 public LispObject execute(LispObject arg) throws ConditionThrowable
499 {
500 final Symbol symbol = checkSymbol(arg);
501 LispObject value =
502 LispThread.currentThread().lookupSpecial(symbol);
503 if (value == null) {
504 value = symbol.symbolValue();
505 if (value instanceof SymbolMacro)
506 signal(new LispError(arg.writeToString() +
507 " has no dynamic value."));
508 }
509 return value;
510 }
511 };
512
513 private static final Primitive2 SET = new Primitive2("set", "symbol value")
516 {
517 public LispObject execute(LispObject first, LispObject second)
518 throws ConditionThrowable
519 {
520 Symbol symbol = checkSymbol(first);
521 Environment dynEnv =
522 LispThread.currentThread().getDynamicEnvironment();
523 if (dynEnv != null) {
524 Binding binding = dynEnv.getBinding(symbol);
525 if (binding != null) {
526 binding.value = second;
527 return second;
528 }
529 }
530 symbol.setSymbolValue(second);
531 return second;
532 }
533 };
534
535 private static final Primitive2 RPLACA =
537 new Primitive2("rplaca", "cons object")
538 {
539 public LispObject execute(LispObject first, LispObject second)
540 throws ConditionThrowable
541 {
542 first.setCar(second);
543 return first;
544 }
545 };
546
547 private static final Primitive2 RPLACD =
549 new Primitive2("rplacd", "cons object")
550 {
551 public LispObject execute(LispObject first, LispObject second)
552 throws ConditionThrowable
553 {
554 first.setCdr(second);
555 return first;
556 }
557 };
558
559 private static final Primitive ADD = new Primitive("+", "&rest numbers")
561 {
562 public LispObject execute(LispObject first, LispObject second)
563 throws ConditionThrowable
564 {
565 return first.add(second);
566 }
567 public LispObject execute(LispObject[] args) throws ConditionThrowable
568 {
569 LispObject result = Fixnum.ZERO;
570 final int length = args.length;
571 for (int i = 0; i < length; i++)
572 result = result.add(args[i]);
573 return result;
574 }
575 };
576
577 private static final Primitive1 ONE_PLUS = new Primitive1("1+", "number")
579 {
580 public LispObject execute(LispObject arg) throws ConditionThrowable
581 {
582 return arg.incr();
583 }
584 };
585
586 private static final Primitive SUBTRACT =
588 new Primitive("-", "minuend &rest subtrahends")
589 {
590 public LispObject execute(LispObject first, LispObject second)
591 throws ConditionThrowable
592 {
593 return first.subtract(second);
594 }
595 public LispObject execute(LispObject[] args) throws ConditionThrowable
596 {
597 switch (args.length) {
598 case 0:
599 signal(new WrongNumberOfArgumentsException("-"));
600 case 1:
601 return Fixnum.ZERO.subtract(args[0]);
602 case 2:
603 Debug.assertTrue(false);
604 return args[0].subtract(args[1]);
605 default: {
606 LispObject result = args[0];
607 for (int i = 1; i < args.length; i++)
608 result = result.subtract(args[i]);
609 return result;
610 }
611 }
612 }
613 };
614
615 private static final Primitive1 ONE_MINUS = new Primitive1("1-","number")
617 {
618 public LispObject execute(LispObject arg) throws ConditionThrowable
619 {
620 return arg.decr();
621 }
622 };
623
624 private static final SpecialOperator WHEN = new SpecialOperator("when")
626 {
627 public LispObject execute(LispObject args, Environment env)
628 throws ConditionThrowable
629 {
630 if (args == NIL)
631 signal(new WrongNumberOfArgumentsException(this));
632 final LispThread thread = LispThread.currentThread();
633 if (eval(args.car(), env, thread) != NIL) {
634 args = args.cdr();
635 LispObject result = NIL;
636 while (args != NIL) {
637 result = eval(args.car(), env, thread);
638 args = args.cdr();
639 }
640 return result;
641 } else
642 return thread.setValues(NIL);
643 }
644 };
645
646 private static final SpecialOperator UNLESS = new SpecialOperator("unless")
648 {
649 public LispObject execute(LispObject args, Environment env)
650 throws ConditionThrowable
651 {
652 if (args == NIL)
653 signal(new WrongNumberOfArgumentsException(this));
654 final LispThread thread = LispThread.currentThread();
655 if (eval(args.car(), env, thread) == NIL) {
656 args = args.cdr();
657 LispObject result = NIL;
658 while (args != NIL) {
659 result = eval(args.car(), env, thread);
660 args = args.cdr();
661 }
662 return result;
663 } else
664 return thread.setValues(NIL);
665 }
666 };
667
668 private static final Primitive2 _OUTPUT_OBJECT =
670 new Primitive2("%output-object", PACKAGE_SYS, false)
671 {
672 public LispObject execute(LispObject first, LispObject second)
673 throws ConditionThrowable
674 {
675 outSynonymOf(second)._writeString(first.writeToString());
676 return first;
677 }
678 };
679
680 private static final Primitive1 _WRITE_TO_STRING =
682 new Primitive1("%write-to-string", PACKAGE_SYS, false)
683 {
684 public LispObject execute(LispObject arg) throws ConditionThrowable
685 {
686 return new SimpleString(arg.writeToString());
687 }
688 };
689
690 private static final Primitive1 PRINC_TO_STRING =
692 new Primitive1("princ-to-string", "object")
693 {
694 public LispObject execute(LispObject arg) throws ConditionThrowable
695 {
696 LispThread thread = LispThread.currentThread();
697 Environment oldDynEnv = thread.getDynamicEnvironment();
698 thread.bindSpecial(_PRINT_ESCAPE_, NIL);
699 thread.bindSpecial(_PRINT_READABLY_, NIL);
700 SimpleString string = new SimpleString(arg.writeToString());
701 thread.setDynamicEnvironment(oldDynEnv);
702 return string;
703 }
704 };
705
706 private static final Primitive1 PRIN1_TO_STRING =
708 new Primitive1("prin1-to-string", "object")
709 {
710 public LispObject execute(LispObject arg) throws ConditionThrowable
711 {
712 LispThread thread = LispThread.currentThread();
713 Environment oldDynEnv = thread.getDynamicEnvironment();
714 thread.bindSpecial(_PRINT_ESCAPE_, T);
715 SimpleString string = new SimpleString(arg.writeToString());
716 thread.setDynamicEnvironment(oldDynEnv);
717 return string;
718 }
719 };
720
721 private static final Primitive1 _TERPRI =
724 new Primitive1("%terpri", PACKAGE_SYS, false, "output-stream")
725 {
726 public LispObject execute(LispObject arg) throws ConditionThrowable
727 {
728 return outSynonymOf(arg).terpri();
729 }
730 };
731
732 private static final Primitive1 _FRESH_LINE =
735 new Primitive1("%fresh-line", PACKAGE_SYS, false, "output-stream")
736 {
737 public LispObject execute(LispObject arg) throws ConditionThrowable
738 {
739 return outSynonymOf(arg).freshLine();
740 }
741 };
742
743 private static final Primitive1 BOUNDP = new Primitive1("boundp", "symbol")
747 {
748 public LispObject execute(LispObject obj) throws ConditionThrowable
749 {
750 Symbol symbol = checkSymbol(obj);
751 Environment dynEnv =
755 LispThread.currentThread().getDynamicEnvironment();
756 if (dynEnv != null) {
757 Binding binding = dynEnv.getBinding(symbol);
758 if (binding != null)
759 return binding.value != null ? T : NIL;
760 }
761 return symbol.getSymbolValue() != null ? T : NIL;
763 }
764 };
765
766 private static final Primitive1 FBOUNDP = new Primitive1("fboundp","name")
768 {
769 public LispObject execute(LispObject arg) throws ConditionThrowable
770 {
771 if (arg instanceof Symbol)
772 return arg.getSymbolFunction() != null ? T : NIL;
773 if (arg instanceof Cons && arg.car() == Symbol.SETF) {
774 LispObject f =
775 get(checkSymbol(arg.cadr()), Symbol._SETF_FUNCTION);
776 return f != null ? T : NIL;
777 }
778 signal(new TypeError(arg, "valid function name"));
779 return NIL;
780 }
781 };
782
783 private static final Primitive1 FMAKUNBOUND = new Primitive1("fmakunbound","name")
785 {
786 public LispObject execute(LispObject arg) throws ConditionThrowable
787 {
788 if (arg instanceof Symbol) {
789 ((Symbol)arg).setSymbolFunction(null);
790 } else if (arg instanceof Cons && arg.car() == Symbol.SETF) {
791 remprop(checkSymbol(arg.cadr()), Symbol._SETF_FUNCTION);
792 } else
793 signal(new TypeError(arg, "valid function name"));
794 return arg;
795 }
796 };
797
798 private static final Primitive2 REMPROP = new Primitive2("remprop","symbol indicator")
800 {
801 public LispObject execute(LispObject first, LispObject second)
802 throws ConditionThrowable
803 {
804 return remprop(checkSymbol(first), second);
805 }
806 };
807
808 public static final Primitive APPEND = new Primitive("append","&rest lists") {
810 public LispObject execute()
811 {
812 return NIL;
813 }
814 public LispObject execute(LispObject arg)
815 {
816 return arg;
817 }
818 public LispObject execute(LispObject first, LispObject second)
819 throws ConditionThrowable
820 {
821 if (first == NIL)
822 return second;
823 Cons result = new Cons(first.car());
825 Cons splice = result;
826 first = first.cdr();
827 while (first != NIL) {
828 Cons temp = new Cons(first.car());
829 splice.setCdr(temp);
830 splice = temp;
831 first = first.cdr();
832 }
833 splice.setCdr(second);
834 return result;
835 }
836 public LispObject execute(LispObject[] args) throws ConditionThrowable
837 {
838 Cons result = null;
839 Cons splice = null;
840 final int limit = args.length - 1;
841 int i;
842 for (i = 0; i < limit; i++) {
843 LispObject top = args[i];
844 if (top == NIL)
845 continue;
846 result = new Cons(top.car());
847 splice = result;
848 top = top.cdr();
849 while (top != NIL) {
850 Cons temp = new Cons(top.car());
851 splice.setCdr(temp);
852 splice = temp;
853 top = top.cdr();
854 }
855 break;
856 }
857 if (result == null)
858 return args[i];
859 for (++i; i < limit; i++) {
860 LispObject top = args[i];
861 while (top != NIL) {
862 Cons temp = new Cons(top.car());
863 splice.setCdr(temp);
864 splice = temp;
865 top = top.cdr();
866 }
867 }
868 splice.setCdr(args[i]);
869 return result;
870 }
871 };
872
873 private static final Primitive NCONC = new Primitive("nconc","&rest lists") {
875 public LispObject execute(LispObject[] array) throws ConditionThrowable
876 {
877 switch (array.length) {
878 case 0:
879 return NIL;
880 case 1:
881 return array[0];
882 default: {
883 LispObject result = null;
884 LispObject splice = null;
885 final int limit = array.length - 1;
886 int i;
887 for (i = 0; i < limit; i++) {
888 LispObject list = array[i];
889 if (list == NIL)
890 continue;
891 if (list instanceof Cons) {
892 if (splice != null) {
893 splice.setCdr(list);
894 splice = list;
895 }
896 while (list instanceof Cons) {
897 if (result == null) {
898 result = list;
899 splice = result;
900 } else {
901 splice = list;
902 }
903 list = list.cdr();
904 }
905 } else
906 signal(new TypeError(list, "list"));
907 }
908 if (result == null)
909 return array[i];
910 splice.setCdr(array[i]);
911 return result;
912 }
913 }
914 }
915 };
916
917 private static final Primitive EQUALS = new Primitive("=","&rest numbers") {
920 public LispObject execute(LispObject first, LispObject second)
921 throws ConditionThrowable
922 {
923 return first.isEqualTo(second) ? T : NIL;
924 }
925 public LispObject execute(LispObject[] array) throws ConditionThrowable
926 {
927 final int length = array.length;
928 if (length < 1)
929 signal(new WrongNumberOfArgumentsException(this));
930 final LispObject obj = array[0];
931 for (int i = 1; i < length; i++) {
932 if (array[i].isNotEqualTo(obj))
933 return NIL;
934 }
935 return T;
936 }
937 };
938
939 private static final Primitive NOT_EQUALS =
941 new Primitive("/=", "&rest numbers")
942 {
943 public LispObject execute(LispObject first, LispObject second)
944 throws ConditionThrowable
945 {
946 return first.isNotEqualTo(second) ? T : NIL;
947 }
948 public LispObject execute(LispObject[] array) throws ConditionThrowable
949 {
950 final int length = array.length;
951 if (length == 2)
952 return array[0].isNotEqualTo(array[1]) ? T : NIL;
953 if (length < 1)
954 signal(new WrongNumberOfArgumentsException(this));
955 for (int i = 0; i < length; i++) {
956 final LispObject obj = array[i];
957 for (int j = i+1; j < length; j++) {
958 if (array[j].isEqualTo(obj))
959 return NIL;
960 }
961 }
962 return T;
963 }
964 };
965
966 private static final Primitive LESS_THAN = new Primitive("<","&rest numbers") {
969 public LispObject execute(LispObject first, LispObject second)
970 throws ConditionThrowable
971 {
972 return first.isLessThan(second) ? T : NIL;
973 }
974 public LispObject execute(LispObject[] array) throws ConditionThrowable
975 {
976 final int length = array.length;
977 if (length < 1)
978 signal(new WrongNumberOfArgumentsException(this));
979 for (int i = 1; i < length; i++) {
980 if (array[i].isLessThanOrEqualTo(array[i-1]))
981 return NIL;
982 }
983 return T;
984 }
985 };
986
987 private static final Primitive LE = new Primitive("<=", "&rest numbers")
989 {
990 public LispObject execute(LispObject first, LispObject second)
991 throws ConditionThrowable
992 {
993 return first.isLessThanOrEqualTo(second) ? T : NIL;
994 }
995 public LispObject execute(LispObject[] array) throws ConditionThrowable
996 {
997 switch (array.length) {
998 case 0:
999 signal(new WrongNumberOfArgumentsException(this));
1000 case 1:
1001 return T;
1002 case 2:
1003 Debug.assertTrue(false);
1004 return array[0].isLessThanOrEqualTo(array[1]) ? T : NIL;
1005 default: {
1006 final int length = array.length;
1007 for (int i = 1; i < length; i++) {
1008 if (array[i].isLessThan(array[i-1]))
1009 return NIL;
1010 }
1011 return T;
1012 }
1013 }
1014 }
1015 };
1016
1017 private static final Primitive GREATER_THAN =
1019 new Primitive(">", "&rest numbers")
1020 {
1021 public LispObject execute(LispObject first, LispObject second)
1022 throws ConditionThrowable
1023 {
1024 return first.isGreaterThan(second) ? T : NIL;
1025 }
1026 public LispObject execute(LispObject[] array) throws ConditionThrowable
1027 {
1028 final int length = array.length;
1029 if (length < 1)
1030 signal(new WrongNumberOfArgumentsException(this));
1031 for (int i = 1; i < length; i++) {
1032 if (array[i].isGreaterThanOrEqualTo(array[i-1]))
1033 return NIL;
1034 }
1035 return T;
1036 }
1037 };
1038
1039 private static final Primitive GE = new Primitive(">=", "&rest numbers")
1041 {
1042 public LispObject execute(LispObject first, LispObject second)
1043 throws ConditionThrowable
1044 {
1045 return first.isGreaterThanOrEqualTo(second) ? T : NIL;
1046 }
1047 public LispObject execute(LispObject[] array) throws ConditionThrowable
1048 {
1049 final int length = array.length;
1050 switch (length) {
1051 case 0:
1052 signal(new WrongNumberOfArgumentsException(this));
1053 case 1:
1054 return T;
1055 case 2:
1056 Debug.assertTrue(false);
1057 return array[0].isGreaterThanOrEqualTo(array[1]) ? T : NIL;
1058 default:
1059 for (int i = 1; i < length; i++) {
1060 if (array[i].isGreaterThan(array[i-1]))
1061 return NIL;
1062 }
1063 return T;
1064 }
1065 }
1066 };
1067
1068 private static final Primitive ASSOC =
1073 new Primitive("assoc", "item alist &key key test test-not")
1074 {
1075 public LispObject execute(LispObject[] args) throws ConditionThrowable
1076 {
1077 if (args.length != 2)
1078 signal(new WrongNumberOfArgumentsException(this));
1079 LispObject item = args[0];
1080 LispObject alist = args[1];
1081 while (alist != NIL) {
1082 LispObject cons = alist.car();
1083 if (cons instanceof Cons) {
1084 if (cons.car().eql(item))
1085 return cons;
1086 } else if (cons != NIL)
1087 signal(new TypeError(cons, "list"));
1088 alist = alist.cdr();
1089 }
1090 return NIL;
1091 }
1092 };
1093
1094 private static final Primitive2 NTH = new Primitive2("nth", "n list")
1097 {
1098 public LispObject execute(LispObject first, LispObject second)
1099 throws ConditionThrowable
1100 {
1101 int index = Fixnum.getValue(first);
1102 if (index < 0)
1103 signal(new TypeError("NTH: invalid index " + index + "."));
1104 int i = 0;
1105 while (true) {
1106 if (i == index)
1107 return second.car();
1108 second = second.cdr();
1109 if (second == NIL)
1110 return NIL;
1111 ++i;
1112 }
1113 }
1114 };
1115
1116 private static final Primitive3 _SET_NTH =
1119 new Primitive3("%set-nth", PACKAGE_SYS, false)
1120 {
1121 public LispObject execute(LispObject first, LispObject second,
1122 LispObject third)
1123 throws ConditionThrowable
1124 {
1125 int index = Fixnum.getValue(first);
1126 if (index < 0)
1127 signal(new TypeError("(SETF NTH): invalid index " + index + "."));
1128 int i = 0;
1129 while (true) {
1130 if (i == index) {
1131 second.setCar(third);
1132 return third;
1133 }
1134 second = second.cdr();
1135 if (second == NIL) {
1136 return signal(new LispError("(SETF NTH): the index " +
1137 index + "is too large."));
1138 }
1139 ++i;
1140 }
1141 }
1142 };
1143
1144 private static final Primitive2 NTHCDR = new Primitive2("nthcdr", "n list")
1146 {
1147 public LispObject execute(LispObject first, LispObject second)
1148 throws ConditionThrowable
1149 {
1150 final int index = Fixnum.getValue(first);
1151 if (index < 0)
1152 signal(new TypeError("NTHCDR: invalid index " + index + "."));
1153 for (int i = 0; i < index; i++) {
1154 second = second.cdr();
1155 if (second == NIL)
1156 return NIL;
1157 }
1158 return second;
1159 }
1160 };
1161
1162 private static final Primitive ERROR = new Primitive("error", "datum &rest arguments")
1164 {
1165 public LispObject execute(LispObject[] args) throws ConditionThrowable
1166 {
1167 if (args.length < 1) {
1168 signal(new WrongNumberOfArgumentsException(this));
1169 return NIL;
1170 }
1171 LispObject datum = args[0];
1172 if (datum instanceof Condition) {
1173 signal((Condition)datum);
1174 return NIL;
1175 }
1176 if (datum instanceof Symbol) {
1177 LispObject initArgs = NIL;
1178 for (int i = 1; i < args.length; i++)
1179 initArgs = new Cons(args[i], initArgs);
1180 initArgs = initArgs.nreverse();
1181 Condition condition;
1182 if (datum == Symbol.FILE_ERROR)
1183 condition = new FileError(initArgs);
1184 else if (datum == Symbol.PACKAGE_ERROR)
1185 condition = new PackageError(initArgs);
1186 else if (datum == Symbol.PARSE_ERROR)
1187 condition = new ParseError(initArgs);
1188 else if (datum == Symbol.PROGRAM_ERROR)
1189 condition = new ProgramError(initArgs);
1190 else if (datum == Symbol.SIMPLE_CONDITION)
1191 condition = new SimpleCondition(initArgs);
1192 else if (datum == Symbol.SIMPLE_WARNING)
1193 condition = new SimpleWarning(initArgs);
1194 else if (datum == Symbol.UNBOUND_SLOT)
1195 condition = new UnboundSlot(initArgs);
1196 else if (datum == Symbol.WARNING)
1197 condition = new Warning(initArgs);
1198 else if (datum == Symbol.SIMPLE_ERROR)
1199 condition = new SimpleError(initArgs);
1200 else if (datum == Symbol.SIMPLE_TYPE_ERROR)
1201 condition = new SimpleTypeError(initArgs);
1202 else if (datum == Symbol.CONTROL_ERROR)
1203 condition = new ControlError(initArgs);
1204 else if (datum == Symbol.TYPE_ERROR)
1205 condition = new TypeError(initArgs);
1206 else if (datum == Symbol.UNDEFINED_FUNCTION)
1207 condition = new UndefinedFunction(initArgs);
1208 else
1209 condition = new SimpleError(initArgs);
1211 signal(condition);
1212 return NIL;
1213 }
1214 LispObject formatControl = args[0];
1216 LispObject formatArguments = NIL;
1217 for (int i = 1; i < args.length; i++)
1218 formatArguments = new Cons(args[i], formatArguments);
1219 formatArguments = formatArguments.nreverse();
1220 signal(new SimpleError(formatControl, formatArguments));
1221 return NIL;
1222 }
1223 };
1224
1225 private static final Primitive SIGNAL =
1227 new Primitive("signal", "datum &rest arguments")
1228 {
1229 public LispObject execute(LispObject[] args) throws ConditionThrowable
1230 {
1231 if (args.length < 1)
1232 throw new ConditionThrowable(new WrongNumberOfArgumentsException(this));
1233 if (args[0] instanceof Condition)
1234 throw new ConditionThrowable((Condition)args[0]);
1235 throw new ConditionThrowable (new SimpleCondition());
1236 }
1237 };
1238
1239 private static final Primitive _FORMAT =
1241 new Primitive("%format", PACKAGE_SYS, false,
1242 "destination control-string &rest args")
1243 {
1244 public LispObject execute(LispObject[] args) throws ConditionThrowable
1245 {
1246 if (args.length < 2)
1247 signal(new WrongNumberOfArgumentsException(this));
1248 LispObject destination = args[0];
1249 LispObject[] _args = new LispObject[args.length-1];
1251 for (int i = 0; i < _args.length; i++)
1252 _args[i] = args[i+1];
1253 String s = _format(_args);
1254 if (destination == T) {
1255 checkCharacterOutputStream(_STANDARD_OUTPUT_.symbolValue())._writeString(s);
1256 return NIL;
1257 }
1258 if (destination == NIL)
1259 return new SimpleString(s);
1260 if (destination instanceof TwoWayStream) {
1261 Stream out = ((TwoWayStream)destination).getOutputStream();
1262 if (out instanceof Stream) {
1263 ((Stream)out)._writeString(s);
1264 return NIL;
1265 }
1266 signal(new TypeError(destination, "character output stream"));
1267 }
1268 if (destination instanceof Stream) {
1269 ((Stream)destination)._writeString(s);
1270 return NIL;
1271 }
1272 return NIL;
1273 }
1274 };
1275
1276 private static final String _format(LispObject[] args) throws ConditionThrowable
1277 {
1278 LispObject formatControl = args[0];
1279 LispObject formatArguments = NIL;
1280 for (int i = 1; i < args.length; i++)
1281 formatArguments = new Cons(args[i], formatArguments);
1282 formatArguments = formatArguments.nreverse();
1283 return format(formatControl, formatArguments);
1284 }
1285
1286 private static final Symbol _SIMPLE_FORMAT_FUNCTION_ =
1287 internSpecial("*SIMPLE-FORMAT-FUNCTION*", PACKAGE_SYS, _FORMAT);
1288
1289 private static final Primitive _DEFUN =
1292 new Primitive("%defun", PACKAGE_SYS, false,
1293 "function-name lambda-list body &optional environment")
1294 {
1295 public LispObject execute(LispObject first, LispObject second,
1296 LispObject third)
1297 throws ConditionThrowable
1298 {
1299 return execute(first, second, third, new Environment());
1300 }
1301
1302 public LispObject execute(LispObject first, LispObject second,
1303 LispObject third, LispObject fourth)
1304 throws ConditionThrowable
1305 {
1306 Environment env;
1307 if (fourth != NIL)
1308 env = checkEnvironment(fourth);
1309 else
1310 env = new Environment();
1311 final Symbol symbol;
1312 if (first instanceof Symbol) {
1313 symbol = (Symbol) first;
1314 if (symbol.getSymbolFunction() instanceof SpecialOperator) {
1315 String message =
1316 symbol.getName() + " is a special operator and may not be redefined.";
1317 return signal(new ProgramError(message));
1318 }
1319 } else if (first instanceof Cons && first.car() == Symbol.SETF) {
1320 symbol = checkSymbol(first.cadr());
1321 } else
1322 return signal(new TypeError(first.writeToString() +
1323 " is not a valid function name."));
1324 LispObject arglist = checkList(second);
1325 LispObject body = checkList(third);
1326 if (body.car() instanceof AbstractString && body.cdr() != NIL) {
1327 if (first instanceof Symbol)
1329 symbol.setFunctionDocumentation(body.car());
1330 else
1331 ; body = body.cdr();
1333 }
1334 LispObject decls = NIL;
1335 while (body.car() instanceof Cons && body.car().car() == Symbol.DECLARE) {
1336 decls = new Cons(body.car(), decls);
1337 body = body.cdr();
1338 }
1339 body = new Cons(symbol, body);
1340 body = new Cons(Symbol.BLOCK, body);
1341 body = new Cons(body, NIL);
1342 while (decls != NIL) {
1343 body = new Cons(decls.car(), body);
1344 decls = decls.cdr();
1345 }
1346 Closure closure = new Closure(first instanceof Symbol ? symbol : null,
1347 arglist, body, env);
1348 closure.setArglist(arglist);
1349 if (first instanceof Symbol) {
1350 symbol.setSymbolFunction(closure);
1351 } else {
1352 put(symbol, Symbol._SETF_FUNCTION, closure);
1354 }
1355 if (FUNCTION_TABLE != null) {
1357 FUNCTION_TABLE.remhash(first);
1358 }
1359 return first;
1360 }
1361 };
1362
1363 private static final Primitive MACRO_FUNCTION =
1366 new Primitive("macro-function", "symbol &optional environment")
1367 {
1368 public LispObject execute(LispObject arg) throws ConditionThrowable
1369 {
1370 LispObject obj = arg.getSymbolFunction();
1371 if (obj instanceof AutoloadMacro) {
1372 ((AutoloadMacro)obj).load();
1373 obj = arg.getSymbolFunction();
1374 }
1375 if (obj instanceof MacroObject)
1376 return ((MacroObject)obj).getExpander();
1377 if (obj instanceof SpecialOperator) {
1378 obj = get((Symbol) arg, Symbol.MACROEXPAND_MACRO, NIL);
1379 if (obj instanceof AutoloadMacro) {
1380 ((AutoloadMacro)obj).load();
1381 obj = get((Symbol) arg, Symbol.MACROEXPAND_MACRO, NIL);
1382 }
1383 if (obj instanceof MacroObject)
1384 return ((MacroObject)obj).getExpander();
1385 }
1386 return NIL;
1387 }
1388 };
1389
1390 private static final SpecialOperator DEFMACRO = new SpecialOperator("defmacro")
1392 {
1393 public LispObject execute(LispObject args, Environment env)
1394 throws ConditionThrowable
1395 {
1396 Symbol symbol = checkSymbol(args.car());
1397 LispObject lambdaList = checkList(args.cadr());
1398 LispObject body = args.cddr();
1399 LispObject block = new Cons(Symbol.BLOCK, new Cons(symbol, body));
1400 LispObject toBeApplied =
1401 list2(Symbol.FUNCTION, list3(Symbol.LAMBDA, lambdaList, block));
1402 LispObject formArg = gensym("FORM-");
1403 LispObject envArg = gensym("ENV-"); LispObject expander =
1405 list3(Symbol.LAMBDA, list2(formArg, envArg),
1406 list3(Symbol.APPLY, toBeApplied,
1407 list2(Symbol.CDR, formArg)));
1408 Closure expansionFunction =
1409 new Closure(expander.cadr(), expander.cddr(), env);
1410 MacroObject macroObject = new MacroObject(expansionFunction);
1411 if (symbol.getSymbolFunction() instanceof SpecialOperator)
1412 put(symbol, Symbol.MACROEXPAND_MACRO, macroObject);
1413 else
1414 symbol.setSymbolFunction(macroObject);
1415 macroObject.setArglist(lambdaList);
1416 LispThread.currentThread().clearValues();
1417 return symbol;
1418 }
1419 };
1420
1421 private static final Primitive1 MAKE_MACRO =
1423 new Primitive1("make-macro", PACKAGE_SYS, false)
1424 {
1425 public LispObject execute(LispObject arg) throws ConditionThrowable
1426 {
1427 return new MacroObject(arg);
1428 }
1429 };
1430
1431 private static final Primitive3 _DEFPARAMETER =
1433 new Primitive3("%defparameter", PACKAGE_SYS, false)
1434 {
1435 public LispObject execute(LispObject first, LispObject second,
1436 LispObject third)
1437 throws ConditionThrowable
1438 {
1439 Symbol symbol = checkSymbol(first);
1440 if (third instanceof AbstractString)
1441 symbol.setVariableDocumentation(third);
1442 else if (third != NIL)
1443 signal(new TypeError(third, "string"));
1444 symbol.setSymbolValue(second);
1445 symbol.setSpecial(true);
1446 return symbol;
1447 }
1448 };
1449
1450 private static final Primitive1 _DEFVAR =
1452 new Primitive1("%defvar", PACKAGE_SYS, false)
1453 {
1454 public LispObject execute(LispObject arg) throws ConditionThrowable
1455 {
1456 Symbol symbol = checkSymbol(arg);
1457 symbol.setSpecial(true);
1458 return symbol;
1459 }
1460 };
1461
1462 private static final Primitive3 _DEFCONSTANT =
1464 new Primitive3("%defconstant", PACKAGE_SYS, false)
1465 {
1466 public LispObject execute(LispObject first, LispObject second,
1467 LispObject third)
1468 throws ConditionThrowable
1469 {
1470 Symbol symbol = checkSymbol(first);
1471 if (third instanceof AbstractString)
1472 symbol.setVariableDocumentation(third);
1473 else if (third != NIL)
1474 signal(new TypeError(third, "string"));
1475 symbol.setSymbolValue(second);
1476 symbol.setSpecial(true);
1477 symbol.setConstant(true);
1478 return symbol;
1479 }
1480 };
1481
1482 private static final SpecialOperator COND = new SpecialOperator("cond", "&rest clauses") {
1484 public LispObject execute(LispObject args, Environment env)
1485 throws ConditionThrowable
1486 {
1487 final LispThread thread = LispThread.currentThread();
1488 LispObject result = NIL;
1489 while (args != NIL) {
1490 LispObject clause = args.car();
1491 result = eval(clause.car(), env, thread);
1492 thread.clearValues();
1493 if (result != NIL) {
1494 LispObject body = clause.cdr();
1495 while (body != NIL) {
1496 result = eval(body.car(), env, thread);
1497 body = body.cdr();
1498 }
1499 return result;
1500 }
1501 args = args.cdr();
1502 }
1503 return result;
1504 }
1505 };
1506
1507 private static final SpecialOperator CASE = new SpecialOperator("case", "keyform &body cases")
1509 {
1510 public LispObject execute(LispObject args, Environment env)
1511 throws ConditionThrowable
1512 {
1513 final LispThread thread = LispThread.currentThread();
1514 LispObject key = eval(args.car(), env, thread);
1515 args = args.cdr();
1516 while (args != NIL) {
1517 LispObject clause = args.car();
1518 LispObject keys = clause.car();
1519 boolean match = false;
1520 if (keys.listp()) {
1521 while (keys != NIL) {
1522 LispObject candidate = keys.car();
1523 if (key.eql(candidate)) {
1524 match = true;
1525 break;
1526 }
1527 keys = keys.cdr();
1528 }
1529 } else {
1530 LispObject candidate = keys;
1531 if (candidate == T || candidate == Symbol.OTHERWISE)
1532 match = true;
1533 else if (key.eql(candidate))
1534 match = true;
1535 }
1536 if (match) {
1537 return progn(clause.cdr(), env, thread);
1538 }
1539 args = args.cdr();
1540 }
1541 return NIL;
1542 }
1543 };
1544
1545 private static final SpecialOperator ECASE = new SpecialOperator("ecase", "keyform &body cases")
1547 {
1548 public LispObject execute(LispObject args, Environment env)
1549 throws ConditionThrowable
1550 {
1551 final LispThread thread = LispThread.currentThread();
1552 LispObject key = eval(args.car(), env, thread);
1553 args = args.cdr();
1554 while (args != NIL) {
1555 LispObject clause = args.car();
1556 LispObject keys = clause.car();
1557 boolean match = false;
1558 if (keys.listp()) {
1559 while (keys != NIL) {
1560 LispObject candidate = keys.car();
1561 if (key.eql(candidate)) {
1562 match = true;
1563 break;
1564 }
1565 keys = keys.cdr();
1566 }
1567 } else {
1568 LispObject candidate = keys;
1569 if (key.eql(candidate))
1570 match = true;
1571 }
1572 if (match) {
1573 return progn(clause.cdr(), env, thread);
1574 }
1575 args = args.cdr();
1576 }
1577 signal(new TypeError("ECASE: no match for " + key));
1578 return NIL;
1579 }
1580 };
1581
1582 private static final Primitive UPGRADED_ARRAY_ELEMENT_TYPE =
1586 new Primitive("upgraded-array-element-type", "typespec &optional environment") {
1587 public LispObject execute(LispObject arg) throws ConditionThrowable
1588 {
1589 return getUpgradedArrayElementType(arg);
1590 }
1591 public LispObject execute(LispObject first, LispObject second)
1592 throws ConditionThrowable
1593 {
1594 return getUpgradedArrayElementType(first);
1596 }
1597 };
1598
1599 private static final Primitive1 ARRAY_RANK =
1602 new Primitive1("array-rank", "array") {
1603 public LispObject execute(LispObject arg) throws ConditionThrowable
1604 {
1605 return new Fixnum(checkArray(arg).getRank());
1606 }
1607 };
1608
1609 private static final Primitive1 ARRAY_DIMENSIONS =
1613 new Primitive1("array-dimensions", "array") {
1614 public LispObject execute(LispObject arg) throws ConditionThrowable
1615 {
1616 return checkArray(arg).getDimensions();
1617 }
1618 };
1619
1620 private static final Primitive2 ARRAY_DIMENSION =
1623 new Primitive2("array-dimension", "array axis-number") {
1624 public LispObject execute(LispObject first, LispObject second)
1625 throws ConditionThrowable
1626 {
1627 return new Fixnum(checkArray(first).getDimension(Fixnum.getValue(second)));
1628 }
1629 };
1630
1631 private static final Primitive1 ARRAY_TOTAL_SIZE =
1634 new Primitive1("array-total-size","array") {
1635 public LispObject execute(LispObject arg) throws ConditionThrowable
1636 {
1637 return new Fixnum(checkArray(arg).getTotalSize());
1638 }
1639 };
1640
1641
1642 private static final Primitive1 ARRAY_ELEMENT_TYPE =
1645 new Primitive1("array-element-type", "array")
1646 {
1647 public LispObject execute(LispObject arg) throws ConditionThrowable
1648 {
1649 return checkArray(arg).getElementType();
1650 }
1651 };
1652
1653 private static final Primitive1 ADJUSTABLE_ARRAY_P =
1655 new Primitive1("adjustable-array-p", "array")
1656 {
1657 public LispObject execute(LispObject arg) throws ConditionThrowable
1658 {
1659 try {
1660 return ((AbstractArray)arg).isAdjustable() ? T : NIL;
1661 }
1662 catch (ClassCastException e) {
1663 return signal(new TypeError(arg, Symbol.ARRAY));
1664 }
1665 }
1666 };
1667
1668 private static final Primitive1 ARRAY_DISPLACEMENT =
1671 new Primitive1("array-displacement", "array")
1672 {
1673 public LispObject execute(LispObject arg) throws ConditionThrowable
1674 {
1675 return checkArray(arg).arrayDisplacement();
1676 }
1677 };
1678
1679 private static final Primitive ARRAY_IN_BOUNDS_P =
1682 new Primitive("array-in-bounds-p", "array &rest subscripts")
1683 {
1684 public LispObject execute(LispObject[] args) throws ConditionThrowable
1685 {
1686 if (args.length < 1)
1687 signal(new WrongNumberOfArgumentsException(this));
1688 AbstractArray array = checkArray(args[0]);
1689 int rank = array.getRank();
1690 if (rank != args.length - 1) {
1691 StringBuffer sb = new StringBuffer ("ARRAY-IN-BOUNDS-P: ");
1692 sb.append("wrong number of subscripts (");
1693 sb.append(args.length - 1);
1694 sb.append(") for array of rank ");
1695 sb.append(rank);
1696 signal(new ProgramError(sb.toString()));
1697 }
1698 for (int i = 0; i < rank; i++) {
1699 LispObject arg = args[i+1];
1700 if (arg instanceof Fixnum) {
1701 int subscript = ((Fixnum)arg).getValue();
1702 if (subscript < 0 || subscript >= array.getDimension(i))
1703 return NIL;
1704 } else if (arg instanceof Bignum) {
1705 return NIL;
1706 } else
1707 signal(new TypeError(arg, "integer"));
1708 }
1709 return T;
1710 }
1711 };
1712
1713 private static final Primitive2 _ARRAY_ROW_MAJOR_INDEX =
1716 new Primitive2("%array-row-major-index", PACKAGE_SYS, false)
1717 {
1718 public LispObject execute(LispObject first, LispObject second)
1719 throws ConditionThrowable
1720 {
1721 AbstractArray array = checkArray(first);
1722 LispObject[] subscripts = second.copyToArray();
1723 return number(array.getRowMajorIndex(subscripts));
1724 }
1725 };
1726
1727 private static final Primitive AREF =
1730 new Primitive("aref", "array &rest subscripts")
1731 {
1732 public LispObject execute() throws ConditionThrowable
1733 {
1734 return signal(new WrongNumberOfArgumentsException(this));
1735 }
1736
1737 public LispObject execute(LispObject arg) throws ConditionThrowable
1738 {
1739 AbstractArray array = checkArray(arg);
1740 if (array.getRank() == 0)
1741 return array.getRowMajor(0);
1742 StringBuffer sb =
1743 new StringBuffer ("Wrong number of subscripts (0) for array of rank ");
1744 sb.append(array.getRank());
1745 sb.append('.');
1746 signal(new ProgramError(sb.toString()));
1747 return NIL;
1748 }
1749
1750 public LispObject execute(LispObject first, LispObject second)
1751 throws ConditionThrowable
1752 {
1753 return first.AREF(second);
1754 }
1755
1756 public LispObject execute(LispObject first, LispObject second,
1757 LispObject third)
1758 throws ConditionThrowable
1759 {
1760 final AbstractArray array;
1761 try {
1762 array = checkArray(first);
1763 }
1764 catch (ClassCastException e) {
1765 return signal(new TypeError(first, Symbol.ARRAY));
1766 }
1767 final int[] subs = new int[2];
1768 try {
1769 subs[0] = ((Fixnum)second).value;
1770 }
1771 catch (ClassCastException e) {
1772 return signal(new TypeError(second, Symbol.FIXNUM));
1773 }
1774 try {
1775 subs[1] = ((Fixnum)third).value;
1776 }
1777 catch (ClassCastException e) {
1778 return signal(new TypeError(third, Symbol.FIXNUM));
1779 }
1780 return array.get(subs);
1781 }
1782
1783 public LispObject execute(LispObject[] args) throws ConditionThrowable
1784 {
1785 final AbstractArray array;
1786 try {
1787 array = checkArray(args[0]);
1788 }
1789 catch (ClassCastException e) {
1790 return signal(new TypeError(args[0], Symbol.ARRAY));
1791 }
1792 final int[] subs = new int[args.length - 1];
1793 for (int i = subs.length; i-- > 0;) {
1794 try {
1795 subs[i] = ((Fixnum)args[i+1]).value;
1796 }
1797 catch (ClassCastException e) {
1798 return signal(new TypeError(args[i+i], Symbol.FIXNUM));
1799 }
1800 }
1801 return array.get(subs);
1802 }
1803 };
1804
1805 private static final Primitive _ASET =
1808 new Primitive("%aset", PACKAGE_SYS, false, "array subscripts new-element")
1809 {
1810 public LispObject execute() throws ConditionThrowable
1811 {
1812 return signal(new WrongNumberOfArgumentsException(this));
1813 }
1814
1815 public LispObject execute(LispObject arg) throws ConditionThrowable
1816 {
1817 return signal(new WrongNumberOfArgumentsException(this));
1818 }
1819
1820 public LispObject execute(LispObject first, LispObject second)
1821 throws ConditionThrowable
1822 {
1823 final ZeroRankArray array;
1825 try {
1826 array = (ZeroRankArray) first;
1827 }
1828 catch (ClassCastException e) {
1829 return signal(new TypeError(first + " is not an array of rank 0."));
1830 }
1831 array.setRowMajor(0, second);
1832 return second;
1833 }
1834
1835 public LispObject execute(LispObject first, LispObject second,
1836 LispObject third)
1837 throws ConditionThrowable
1838 {
1839 final AbstractVector v;
1840 try {
1841 v = (AbstractVector) first;
1842 }
1843 catch (ClassCastException e) {
1844 return signal(new TypeError(first, Symbol.VECTOR));
1845 }
1846 final int index;
1847 try {
1848 index = ((Fixnum)second).value;
1849 }
1850 catch (ClassCastException e) {
1851 return signal(new TypeError(second, Symbol.FIXNUM));
1852 }
1853 v.setRowMajor(index, third);
1854 return third;
1855 }
1856
1857 public LispObject execute(LispObject[] args) throws ConditionThrowable
1858 {
1859 final AbstractArray array;
1860 try {
1861 array = (AbstractArray) args[0];
1862 }
1863 catch (ClassCastException e) {
1864 return signal(new TypeError(args[0], Symbol.ARRAY));
1865 }
1866 final int nsubs = args.length - 2;
1867 final int[] subs = new int[nsubs];
1868 for (int i = nsubs; i-- > 0;) {
1869 try {
1870 subs[i] = ((Fixnum)args[i+1]).value;
1871 }
1872 catch (ClassCastException e) {
1873 signal(new TypeError(args[i+1], Symbol.FIXNUM));
1874 }
1875 }
1876 final LispObject newValue = args[args.length - 1];
1877 array.set(subs, newValue);
1878 return newValue;
1879 }
1880 };
1881
1882 private static final Primitive2 ROW_MAJOR_AREF =
1885 new Primitive2("row-major-aref", "array index")
1886 {
1887 public LispObject execute(LispObject first, LispObject second)
1888 throws ConditionThrowable
1889 {
1890 try {
1891 return ((AbstractArray)first).getRowMajor(((Fixnum)second).value);
1892 }
1893 catch (ClassCastException e) {
1894 if (first instanceof AbstractArray)
1895 return signal(new TypeError(second, Symbol.FIXNUM));
1896 else
1897 return signal(new TypeError(first, Symbol.ARRAY));
1898 }
1899 }
1900 };
1901
1902 private static final Primitive3 _SET_ROW_MAJOR_AREF =
1905 new Primitive3("%set-row-major-aref", PACKAGE_SYS, false)
1906 {
1907 public LispObject execute(LispObject first, LispObject second,
1908 LispObject third)
1909 throws ConditionThrowable
1910 {
1911 try {
1912 ((AbstractArray)first).setRowMajor(((Fixnum)second).value, third);
1913 return third;
1914 }
1915 catch (ClassCastException e) {
1916 if (first instanceof AbstractArray)
1917 return signal(new TypeError(second, Symbol.FIXNUM));
1918 else
1919 return signal(new TypeError(first, Symbol.ARRAY));
1920 }
1921 }
1922 };
1923
1924 private static final Primitive VECTOR = new Primitive("vector", "&rest objects")
1926 {
1927 public LispObject execute(LispObject[] args) throws ConditionThrowable
1928 {
1929 return new SimpleVector(args);
1930 }
1931 };
1932
1933 private static final Primitive3 _VSET =
1936 new Primitive3("%vset", PACKAGE_SYS, false)
1937 {
1938 public LispObject execute(LispObject first, LispObject second,
1939 LispObject third)
1940 throws ConditionThrowable
1941 {
1942 try {
1943 ((AbstractVector)first).setRowMajor(((Fixnum)second).value, third);
1944 return third;
1945 }
1946 catch (ClassCastException e) {
1947 if (first instanceof AbstractVector)
1948 return signal(new TypeError(second, Symbol.FIXNUM));
1949 else
1950 return signal(new TypeError(first, Symbol.VECTOR));
1951 }
1952 }
1953 };
1954
1955 private static final Primitive1 FILL_POINTER =
1957 new Primitive1("fill-pointer", "vector")
1958 {
1959 public LispObject execute(LispObject arg)
1960 throws ConditionThrowable
1961 {
1962 try {
1963 return new Fixnum(((AbstractArray)arg).getFillPointer());
1964 }
1965 catch (ClassCastException e) {
1966 return signal(new TypeError(arg, Symbol.ARRAY));
1967 }
1968 }
1969 };
1970
1971 private static final Primitive2 _SET_FILL_POINTER =
1973 new Primitive2("%set-fill-pointer", PACKAGE_SYS, false) {
1974 public LispObject execute(LispObject first, LispObject second)
1975 throws ConditionThrowable
1976 {
1977 try {
1978 AbstractVector v = (AbstractVector) first;
1979 if (v.hasFillPointer())
1980 v.setFillPointer(second);
1981 else
1982 v.noFillPointer();
1983 return second;
1984 }
1985 catch (ClassCastException e) {
1986 return signal(new TypeError(first, Symbol.VECTOR));
1987 }
1988 }
1989 };
1990
1991 private static final Primitive2 VECTOR_PUSH =
1993 new Primitive2("vector-push","new-element vector")
1994 {
1995 public LispObject execute(LispObject first, LispObject second)
1996 throws ConditionThrowable
1997 {
1998 AbstractVector v = checkVector(second);
1999 int fillPointer = v.getFillPointer();
2000 if (fillPointer < 0)
2001 v.noFillPointer();
2002 if (fillPointer >= v.capacity())
2003 return NIL;
2004 v.setRowMajor(fillPointer, first);
2005 v.setFillPointer(fillPointer + 1);
2006 return new Fixnum(fillPointer);
2007 }
2008 };
2009
2010 private static final Primitive VECTOR_PUSH_EXTEND =
2013 new Primitive("vector-push-extend",
2014 "new-element vector &optional extension")
2015 {
2016 public LispObject execute(LispObject first, LispObject second)
2017 throws ConditionThrowable
2018 {
2019 try {
2020 return ((AbstractVector)second).vectorPushExtend(first);
2021 }
2022 catch (ClassCastException e) {
2023 return signal(new TypeError(second, Symbol.VECTOR));
2024 }
2025 }
2026
2027 public LispObject execute(LispObject first, LispObject second,
2028 LispObject third)
2029 throws ConditionThrowable
2030 {
2031 try {
2032 return ((AbstractVector)second).vectorPushExtend(first, third);
2033 }
2034 catch (ClassCastException e) {
2035 return signal(new TypeError(second, Symbol.VECTOR));
2036 }
2037 }
2038 };
2039
2040 private static final Primitive1 VECTOR_POP =
2042 new Primitive1("vector-pop", "vector")
2043 {
2044 public LispObject execute(LispObject arg) throws ConditionThrowable
2045 {
2046 AbstractVector v = checkVector(arg);
2047 int fillPointer = v.getFillPointer();
2048 if (fillPointer < 0)
2049 v.noFillPointer();
2050 if (fillPointer == 0)
2051 signal(new LispError("nothing left to pop"));
2052 int newFillPointer = v.checkIndex(fillPointer - 1);
2053 LispObject element = v.getRowMajor(newFillPointer);
2054 v.setFillPointer(newFillPointer);
2055 return element;
2056 }
2057 };
2058
2059 private static final Primitive1 TYPE_OF = new Primitive1("type-of", "object")
2061 {
2062 public LispObject execute(LispObject arg) throws ConditionThrowable
2063 {
2064 return arg.typeOf();
2065 }
2066 };
2067
2068 private static final Primitive1 CLASS_OF = new Primitive1("class-of", "object")
2070 {
2071 public LispObject execute(LispObject arg) throws ConditionThrowable
2072 {
2073 return arg.classOf();
2074 }
2075 };
2076
2077 private static final Primitive2 SIMPLE_TYPEP =
2079 new Primitive2("simple-typep", PACKAGE_SYS, false)
2080 {
2081 public LispObject execute(LispObject first, LispObject second)
2082 throws ConditionThrowable
2083 {
2084 return first.typep(second);
2085 }
2086 };
2087
2088 private static final Primitive1 FUNCTION_LAMBDA_EXPRESSION =
2091 new Primitive1("function-lambda-expression", "function")
2092 {
2093 public LispObject execute(LispObject arg) throws ConditionThrowable
2094 {
2095 final LispObject value1, value2;
2096 Function function = checkFunction(arg);
2097 String name = function.getName();
2098 final LispObject value3 = name != null ? new SimpleString(name) : NIL;
2099 if (function instanceof CompiledClosure) {
2100 value1 = NIL;
2101 value2 = T;
2102 } else if (function instanceof Closure && !(function instanceof CompiledFunction)) {
2103 Closure closure = (Closure) function;
2104 LispObject expr = closure.getBody();
2105 expr = new Cons(closure.getParameterList(), expr);
2106 expr = new Cons(Symbol.LAMBDA, expr);
2107 value1 = expr;
2108 Environment env = closure.getEnvironment();
2109 if (env == null || env.isEmpty())
2110 value2 = NIL;
2111 else
2112 value2 = env; } else
2114 value1 = value2 = NIL;
2115 return LispThread.currentThread().setValues(value1, value2, value3);
2116 }
2117 };
2118
2119 public static final Primitive FUNCALL =
2122 new Primitive("funcall", "function &rest args")
2123 {
2124 public LispObject execute(LispObject arg) throws ConditionThrowable
2125 {
2126 return funcall0(requireFunction(arg), LispThread.currentThread());
2127 }
2128 public LispObject execute(LispObject first, LispObject second)
2129 throws ConditionThrowable
2130 {
2131 return funcall1(requireFunction(first), second,
2132 LispThread.currentThread());
2133 }
2134 public LispObject execute(LispObject first, LispObject second,
2135 LispObject third)
2136 throws ConditionThrowable
2137 {
2138 return funcall2(requireFunction(first), second, third,
2139 LispThread.currentThread());
2140 }
2141 public LispObject execute(LispObject[] args) throws ConditionThrowable
2142 {
2143 if (args.length < 1) {
2144 signal(new WrongNumberOfArgumentsException(this));
2145 return NIL;
2146 }
2147 LispObject fun = requireFunction(args[0]);
2148 final int length = args.length - 1; if (length == 3) {
2150 return funcall3(fun, args[1], args[2], args[3],
2151 LispThread.currentThread());
2152 } else {
2153 LispObject[] funArgs = new LispObject[length];
2154 System.arraycopy(args, 1, funArgs, 0, length);
2155 return funcall(fun, funArgs, LispThread.currentThread());
2156 }
2157 }
2158 private LispObject requireFunction(LispObject arg) throws ConditionThrowable
2159 {
2160 if (arg instanceof Function || arg instanceof GenericFunction)
2161 return arg;
2162 if (arg instanceof Symbol) {
2163 LispObject function = arg.getSymbolFunction();
2164 if (function instanceof Function || function instanceof GenericFunction)
2165 return function;
2166 return signal(new UndefinedFunction(arg));
2167 }
2168 return signal(new TypeError(arg, list3(Symbol.OR, Symbol.FUNCTION,
2169 Symbol.SYMBOL)));
2170 }
2171 };
2172
2173 public static final Primitive APPLY =
2175 new Primitive("apply", "function &rest args")
2176 {
2177 public LispObject execute(LispObject first, LispObject second)
2178 throws ConditionThrowable
2179 {
2180 LispObject spread = checkList(second);
2181 LispObject fun = first;
2182 if (fun instanceof Symbol)
2183 fun = fun.getSymbolFunction();
2184 if (fun instanceof Function || fun instanceof GenericFunction) {
2185 final int numFunArgs = spread.length();
2186 final LispThread thread = LispThread.currentThread();
2187 switch (numFunArgs) {
2188 case 1:
2189 return funcall1(fun, spread.car(), thread);
2190 case 2:
2191 return funcall2(fun, spread.car(), spread.cadr(), thread);
2192 case 3:
2193 return funcall3(fun, spread.car(), spread.cadr(),
2194 spread.cdr().cdr().car(), thread);
2195 default: {
2196 final LispObject[] funArgs = new LispObject[numFunArgs];
2197 int j = 0;
2198 while (spread != NIL) {
2199 funArgs[j++] = spread.car();
2200 spread = spread.cdr();
2201 }
2202 return funcall(fun, funArgs, thread);
2203 }
2204 }
2205 }
2206 signal(new TypeError(fun, "function"));
2207 return NIL;
2208 }
2209 public LispObject execute(final LispObject[] args) throws ConditionThrowable
2210 {
2211 final int numArgs = args.length;
2212 if (numArgs < 2)
2213 signal(new WrongNumberOfArgumentsException(this));
2214 LispObject spread = checkList(args[numArgs - 1]);
2215 LispObject fun = args[0];
2216 if (fun instanceof Symbol)
2217 fun = fun.getSymbolFunction();
2218 if (fun instanceof Function || fun instanceof GenericFunction) {
2219 final int numFunArgs = numArgs - 2 + spread.length();
2220 final LispObject[] funArgs = new LispObject[numFunArgs];
2221 int j = 0;
2222 for (int i = 1; i < numArgs - 1; i++)
2223 funArgs[j++] = args[i];
2224 while (spread != NIL) {
2225 funArgs[j++] = spread.car();
2226 spread = spread.cdr();
2227 }
2228 return funcall(fun, funArgs, LispThread.currentThread());
2229 }
2230 signal(new TypeError(fun, "function"));
2231 return NIL;
2232 }
2233 };
2234
2235 private static final Primitive MAPCAR =
2237 new Primitive("mapcar", "function &rest lists")
2238 {
2239 public LispObject execute(LispObject op, LispObject list)
2240 throws ConditionThrowable
2241 {
2242 LispObject fun;
2243 if (op instanceof Symbol)
2244 fun = op.getSymbolFunction();
2245 else
2246 fun = op;
2247 if (fun instanceof Function || fun instanceof GenericFunction) {
2248 final LispThread thread = LispThread.currentThread();
2249 LispObject result = NIL;
2250 LispObject splice = null;
2251 while (list != NIL) {
2252 LispObject obj = funcall1(fun, list.car(), thread);
2253 if (splice == null) {
2254 result = new Cons(obj, result);
2255 splice = result;
2256 } else {
2257 Cons cons = new Cons(obj);
2258 splice.setCdr(cons);
2259 splice = cons;
2260 }
2261 list = list.cdr();
2262 }
2263 thread.clearValues();
2264 return result;
2265 }
2266 signal(new UndefinedFunction(op));
2267 return NIL;
2268 }
2269
2270 public LispObject execute(LispObject first, LispObject second,
2271 LispObject third)
2272 throws ConditionThrowable
2273 {
2274 LispObject fun = first;
2276 if (fun instanceof Symbol)
2277 fun = fun.getSymbolFunction();
2278 if (!(fun instanceof Function || fun instanceof GenericFunction))
2279 signal(new UndefinedFunction(first));
2280 LispObject list1 = checkList(second);
2282 LispObject list2 = checkList(third);
2283 final LispThread thread = LispThread.currentThread();
2284 LispObject result = NIL;
2285 LispObject splice = null;
2286 while (list1 != NIL && list2 != NIL) {
2287 LispObject obj =
2288 funcall2(fun, list1.car(), list2.car(), thread);
2289 if (splice == null) {
2290 result = new Cons(obj, result);
2291 splice = result;
2292 } else {
2293 Cons cons = new Cons(obj);
2294 splice.setCdr(cons);
2295 splice = cons;
2296 }
2297 list1 = list1.cdr();
2298 list2 = list2.cdr();
2299 }
2300 thread.clearValues();
2301 return result;
2302 }
2303
2304 public LispObject execute(final LispObject[] args) throws ConditionThrowable
2305 {
2306 final int numArgs = args.length;
2307 if (numArgs < 2)
2308 signal(new WrongNumberOfArgumentsException(this));
2309 LispObject fun = args[0];
2311 if (fun instanceof Symbol)
2312 fun = fun.getSymbolFunction();
2313 if (!(fun instanceof Function || fun instanceof GenericFunction))
2314 signal(new UndefinedFunction(args[0]));
2315 int commonLength = -1;
2317 for (int i = 1; i < numArgs; i++) {
2318 if (!args[i].listp())
2319 signal(new TypeError(args[i], "list"));
2320 int len = args[i].length();
2321 if (commonLength < 0)
2322 commonLength = len;
2323 else if (commonLength > len)
2324 commonLength = len;
2325 }
2326 final LispThread thread = LispThread.currentThread();
2327 LispObject[] results = new LispObject[commonLength];
2328 final int numFunArgs = numArgs - 1;
2329 final LispObject[] funArgs = new LispObject[numFunArgs];
2330 for (int i = 0; i < commonLength; i++) {
2331 for (int j = 0; j < numFunArgs; j++)
2332 funArgs[j] = args[j+1].car();
2333 results[i] = funcall(fun, funArgs, thread);
2334 for (int j = 1; j < numArgs; j++)
2335 args[j] = args[j].cdr();
2336 }
2337 thread.clearValues();
2338 LispObject result = NIL;
2339 for (int i = commonLength; i-- > 0;)
2340 result = new Cons(results[i], result);
2341 return result;
2342 }
2343 };
2344
2345 private static final Primitive MACROEXPAND =
2347 new Primitive("macroexpand", "form &optional env")
2348 {
2349 public LispObject execute(LispObject[] args) throws ConditionThrowable
2350 {
2351 final int length = args.length;
2352 if (length < 1 || length > 2)
2353 signal(new WrongNumberOfArgumentsException(this));
2354 LispObject form = args[0];
2355 final Environment env;
2356 if (length == 2 && args[1] != NIL)
2357 env = checkEnvironment(args[1]);
2358 else
2359 env = new Environment();
2360 return macroexpand(form, env, LispThread.currentThread());
2361 }
2362 };
2363
2364 private static final Primitive MACROEXPAND_1 =
2366 new Primitive("macroexpand-1", "form &optional env")
2367 {
2368 public LispObject execute(LispObject form) throws ConditionThrowable
2369 {
2370 return macroexpand_1(form,
2371 new Environment(),
2372 LispThread.currentThread());
2373 }
2374 public LispObject execute(LispObject form, LispObject env)
2375 throws ConditionThrowable
2376 {
2377 return macroexpand_1(form,
2378 env != NIL ? checkEnvironment(env) : new Environment(),
2379 LispThread.currentThread());
2380 }
2381 };
2382
2383 private static final Symbol _GENSYM_COUNTER_ =
2385 PACKAGE_CL.addExternalSymbol("*GENSYM-COUNTER*");
2386 static {
2387 _GENSYM_COUNTER_.setSymbolValue(Fixnum.ZERO);
2388 _GENSYM_COUNTER_.setSpecial(true);
2389 }
2390
2391 private static final Primitive GENSYM = new Primitive("gensym", "&optional x")
2393 {
2394 public LispObject execute() throws ConditionThrowable
2395 {
2396 return gensym("G");
2397 }
2398 public LispObject execute(LispObject arg) throws ConditionThrowable
2399 {
2400 String prefix = "G";
2401 if (arg instanceof Fixnum) {
2402 int n = ((Fixnum)arg).getValue();
2403 if (n < 0)
2404 signal(new TypeError(arg, "non-negative integer"));
2405 StringBuffer sb = new StringBuffer (prefix);
2406 sb.append(n);
2407 return new Symbol(sb.toString());
2408 }
2409 if (arg instanceof Bignum) {
2410 BigInteger n = ((Bignum)arg).getValue();
2411 if (n.signum() < 0)
2412 signal(new TypeError(arg, "non-negative integer"));
2413 StringBuffer sb = new StringBuffer (prefix);
2414 sb.append(n.toString());
2415 return new Symbol(sb.toString());
2416 }
2417 if (arg instanceof AbstractString)
2418 prefix = arg.getStringValue();
2419 else
2420 signal(new TypeError(arg, "string or non-negative integer"));
2421 return gensym(prefix);
2422 }
2423 };
2424
2425 private static final Symbol gensym(String prefix) throws ConditionThrowable
2426 {
2427 LispThread thread = LispThread.currentThread();
2428 Environment dynEnv = thread.getDynamicEnvironment();
2429 Binding binding =
2430 (dynEnv == null) ? null : dynEnv.getBinding(_GENSYM_COUNTER_);
2431 LispObject oldValue;
2432 if (binding != null) {
2433 oldValue = binding.value;
2434 binding.value = oldValue.incr();
2435 } else {
2436 oldValue = _GENSYM_COUNTER_.getSymbolValue();
2437 _GENSYM_COUNTER_.setSymbolValue(oldValue.incr());
2438 }
2439 StringBuffer sb = new StringBuffer (prefix);
2440 sb.append(oldValue.writeToString());
2441 return new Symbol(sb.toString());
2442 }
2443
2444 private static final Primitive1 STRING = new Primitive1("string", "x")
2446 {
2447 public LispObject execute(LispObject arg) throws ConditionThrowable
2448 {
2449 return arg.STRING();
2450 }
2451 };
2452
2453 private static final Primitive INTERN =
2457 new Primitive("intern", "string &optional package")
2458 {
2459 public LispObject execute(LispObject arg) throws ConditionThrowable
2460 {
2461 String s = arg.getStringValue();
2462 final LispThread thread = LispThread.currentThread();
2463 Package pkg = (Package ) _PACKAGE_.symbolValueNoThrow(thread);
2464 return pkg.intern(s, thread);
2465 }
2466
2467 public LispObject execute(LispObject first, LispObject second)
2468 throws ConditionThrowable
2469 {
2470 String s = first.getStringValue();
2471 Package pkg = coerceToPackage(second);
2472 return pkg.intern(s, LispThread.currentThread());
2473 }
2474 };
2475
2476 private static final Primitive UNINTERN =
2479 new Primitive("unintern", "symbol &optional package")
2480 {
2481 public LispObject execute(LispObject[] args) throws ConditionThrowable
2482 {
2483 if (args.length == 0 || args.length > 2)
2484 signal(new WrongNumberOfArgumentsException(this));
2485 Symbol symbol = checkSymbol(args[0]);
2486 Package pkg;
2487 if (args.length == 2)
2488 pkg = coerceToPackage(args[1]);
2489 else
2490 pkg = getCurrentPackage();
2491 return pkg.unintern(symbol);
2492 }
2493 };
2494
2495 private static final Primitive1 FIND_PACKAGE =
2497 new Primitive1("find-package", "name") {
2498 public LispObject execute(LispObject arg) throws ConditionThrowable
2499 {
2500 if (arg instanceof Package )
2501 return arg;
2502 if (arg instanceof AbstractString) {
2503 Package pkg =
2504 Packages.findPackage(arg.getStringValue());
2505 return pkg != null ? pkg : NIL;
2506 }
2507 if (arg instanceof Symbol) {
2508 Package pkg = Packages.findPackage(arg.getName());
2509 return pkg != null ? pkg : NIL;
2510 }
2511 if (arg instanceof LispCharacter) {
2512 String packageName =
2513 String.valueOf(new char[] {((LispCharacter)arg).getValue()});
2514 Package pkg = Packages.findPackage(packageName);
2515 return pkg != null ? pkg : NIL;
2516 }
2517 return NIL;
2518 }
2519 };
2520
2521 private static final Primitive3 _MAKE_PACKAGE =
2524 new Primitive3("%make-package", PACKAGE_SYS, false) {
2525 public LispObject execute(LispObject first, LispObject second,
2526 LispObject third)
2527 throws ConditionThrowable
2528 {
2529 String packageName = javaString(first);
2530 Package pkg =
2531 Packages.findPackage(packageName);
2532 if (pkg != null)
2533 signal(new LispError("Package " + packageName +
2534 " already exists."));
2535 LispObject nicknames = checkList(second);
2536 if (nicknames != NIL) {
2537 LispObject list = nicknames;
2538 while (list != NIL) {
2539 String nick = javaString(list.car());
2540 if (Packages.findPackage(nick) != null) {
2541 signal(new PackageError("A package named " + nick +
2542 " already exists."));
2543 }
2544 list = list.cdr();
2545 }
2546 }
2547 LispObject use = checkList(third);
2548 if (use != NIL) {
2549 LispObject list = use;
2550 while (list != NIL) {
2551 LispObject obj = list.car();
2552 if (obj instanceof Package )
2553 ; else {
2555 String s = javaString(obj);
2556 Package p = Packages.findPackage(s);
2557 if (p == null) {
2558 signal(new LispError(obj.writeToString() +
2559 " is not the name of a package."));
2560 return NIL;
2561 }
2562 }
2563 list = list.cdr();
2564 }
2565 }
2566 pkg = Packages.createPackage(packageName);
2568 while (nicknames != NIL) {
2570 String nick = javaString(nicknames.car());
2571 pkg.addNickname(nick);
2572 nicknames = nicknames.cdr();
2573 }
2574 while (use != NIL) {
2576 LispObject obj = use.car();
2577 if (obj instanceof Package )
2578 pkg.usePackage((Package )obj);
2579 else {
2580 String s = javaString(obj);
2581 Package p = Packages.findPackage(s);
2582 if (p == null) {
2583 signal(new LispError(obj.writeToString() +
2584 " is not the name of a package."));
2585 return NIL;
2586 }
2587 pkg.usePackage(p);
2588 }
2589 use = use.cdr();
2590 }
2591 return pkg;
2592 }
2593 };
2594
2595 private static final Primitive1 _IN_PACKAGE =
2597 new Primitive1("%in-package", PACKAGE_SYS, false)
2598 {
2599 public LispObject execute(LispObject arg) throws ConditionThrowable
2600 {
2601 String packageName = javaString(arg);
2602 Package pkg = Packages.findPackage(packageName);
2603 if (pkg == null)
2604 signal(new PackageError("The name " + packageName +
2605 " does not designate any package."));
2606 LispThread thread = LispThread.currentThread();
2607 Environment dynEnv = thread.getDynamicEnvironment();
2608 if (dynEnv != null) {
2609 Binding binding = dynEnv.getBinding(_PACKAGE_);
2610 if (binding != null) {
2611 binding.value = pkg;
2612 return pkg;
2613 }
2614 }
2615 _PACKAGE_.setSymbolValue(pkg);
2617 return pkg;
2618 }
2619 };
2620
2621 private static final Primitive USE_PACKAGE =
2624 new Primitive("use-package","packages-to-use &optional package")
2625 {
2626 public LispObject execute(LispObject[] args) throws ConditionThrowable
2627 {
2628 if (args.length < 1 || args.length > 2)
2629 signal(new WrongNumberOfArgumentsException(this));
2630 Package pkg;
2631 if (args.length == 2)
2632 pkg = coerceToPackage(args[1]);
2633 else
2634 pkg = getCurrentPackage();
2635 if (args[0] instanceof Cons) {
2636 LispObject list = args[0];
2637 while (list != NIL) {
2638 pkg.usePackage(coerceToPackage(list.car()));
2639 list = list.cdr();
2640 }
2641 } else
2642 pkg.usePackage(coerceToPackage(args[0]));
2643 return T;
2644 }
2645 };
2646
2647 private static final Primitive1 PACKAGE_SYMBOLS =
2649 new Primitive1("package-symbols", PACKAGE_SYS, false)
2650 {
2651 public LispObject execute(LispObject arg) throws ConditionThrowable
2652 {
2653 return coerceToPackage(arg).getSymbols();
2654 }
2655 };
2656
2657 private static final Primitive1 PACKAGE_INTERNAL_SYMBOLS =
2659 new Primitive1("package-internal-symbols", PACKAGE_SYS, false)
2660 {
2661 public LispObject execute(LispObject arg) throws ConditionThrowable
2662 {
2663 return coerceToPackage(arg).PACKAGE_INTERNAL_SYMBOLS();
2664 }
2665 };
2666
2667 private static final Primitive1 PACKAGE_EXTERNAL_SYMBOLS =
2669 new Primitive1("package-external-symbols", PACKAGE_SYS, false)
2670 {
2671 public LispObject execute(LispObject arg) throws ConditionThrowable
2672 {
2673 return coerceToPackage(arg).PACKAGE_EXTERNAL_SYMBOLS();
2674 }
2675 };
2676
2677 private static final Primitive1 PACKAGE_INHERITED_SYMBOLS =
2679 new Primitive1("package-inherited-symbols", PACKAGE_SYS, false)
2680 {
2681 public LispObject execute(LispObject arg) throws ConditionThrowable
2682 {
2683 return coerceToPackage(arg).PACKAGE_INHERITED_SYMBOLS();
2684 }
2685 };
2686
2687 private static final Primitive EXPORT =
2689 new Primitive("export", "symbols &optional package")
2690 {
2691 public LispObject execute(LispObject arg) throws ConditionThrowable
2692 {
2693 if (arg instanceof Cons) {
2694 Package pkg = getCurrentPackage();
2695 for (LispObject list = arg; list != NIL; list = list.cdr())
2696 pkg.export(checkSymbol(list.car()));
2697 } else
2698 getCurrentPackage().export(checkSymbol(arg));
2699 return T;
2700 }
2701
2702 public LispObject execute(LispObject first, LispObject second)
2703 throws ConditionThrowable
2704 {
2705 if (first instanceof Cons) {
2706 Package pkg = coerceToPackage(second);
2707 for (LispObject list = first; list != NIL; list = list.cdr())
2708 pkg.export(checkSymbol(list.car()));
2709 } else
2710 coerceToPackage(second).export(checkSymbol(first));
2711 return T;
2712 }
2713 };
2714
2715 private static final Primitive FIND_SYMBOL =
2717 new Primitive("find-symbol", "string &optional package")
2718 {
2719 public LispObject execute(LispObject arg) throws ConditionThrowable
2720 {
2721 return getCurrentPackage().findSymbol(arg.getStringValue());
2722 }
2723
2724 public LispObject execute(LispObject first, LispObject second)
2725 throws ConditionThrowable
2726 {
2727 return coerceToPackage(second).findSymbol(first.getStringValue());
2728 }
2729 };
2730
2731 private static final Primitive FSET =
2733 new Primitive("fset", PACKAGE_SYS, false)
2734 {
2735 public LispObject execute(LispObject first, LispObject second)
2736 throws ConditionThrowable
2737 {
2738 return execute(first, second, NIL, NIL);
2739 }
2740
2741 public LispObject execute(LispObject first, LispObject second,
2742 LispObject third)
2743 throws ConditionThrowable
2744 {
2745 return execute(first, second, third, NIL);
2746 }
2747
2748 public LispObject execute(LispObject first, LispObject second,
2749 LispObject third, LispObject fourth)
2750 throws ConditionThrowable
2751 {
2752 if (first instanceof Symbol) {
2753 Symbol symbol = (Symbol) first;
2754 symbol.setSymbolFunction(second);
2755 LispObject source = Load._FASL_SOURCE_.symbolValue();
2756 if (source != NIL) {
2757 if (third != NIL)
2758 put(symbol, Symbol._SOURCE, new Cons(source, third));
2759 else
2760 put(symbol, Symbol._SOURCE, source);
2761 }
2762 } else if (first instanceof Cons && first.car() == Symbol.SETF) {
2763 Symbol symbol = checkSymbol(first.cadr());
2765 put(symbol, Symbol._SETF_FUNCTION, second);
2766 } else
2767 return signal(new TypeError(first.writeToString() +
2768 " is not a valid function name."));
2769 if (second instanceof Functional) {
2770 ((Functional)second).setLambdaName(first);
2771 if (fourth != NIL)
2772 ((Functional)second).setArglist(fourth);
2773 }
2774 return second;
2775 }
2776 };
2777
2778 private static final Primitive2 _SET_SYMBOL_PLIST =
2780 new Primitive2("%set-symbol-plist", PACKAGE_SYS, false)
2781 {
2782 public LispObject execute(LispObject first, LispObject second)
2783 throws ConditionThrowable
2784 {
2785 checkSymbol(first).setPropertyList(checkList(second));
2786 return second;
2787 }
2788 };
2789
2790 private static final Primitive GETF =
2793 new Primitive("getf", "plist indicator &optional default")
2794 {
2795 public LispObject execute(LispObject plist, LispObject indicator)
2796 throws ConditionThrowable
2797 {
2798 return getf(plist, indicator, NIL);
2799 }
2800
2801 public LispObject execute(LispObject plist, LispObject indicator,
2802 LispObject defaultValue)
2803 throws ConditionThrowable
2804 {
2805 return getf(plist, indicator, defaultValue);
2806 }
2807 };
2808
2809 private static final Primitive GET =
2812 new Primitive("get", "symbol indicator &optional default")
2813 {
2814 public LispObject execute(LispObject symbol, LispObject indicator)
2815 throws ConditionThrowable
2816 {
2817 try {
2818 return get((Symbol)symbol, indicator, NIL);
2819 }
2820 catch (ClassCastException e) {
2821 return signal(new TypeError(symbol, Symbol.SYMBOL));
2822 }
2823 }
2824
2825 public LispObject execute(LispObject symbol, LispObject indicator,
2826 LispObject defaultValue)
2827 throws ConditionThrowable
2828 {
2829 try {
2830 return get((Symbol)symbol, indicator, defaultValue);
2831 }
2832 catch (ClassCastException e) {
2833 return signal(new TypeError(symbol, Symbol.SYMBOL));
2834 }
2835 }
2836 };
2837
2838 private static final Primitive _PUT =
2841 new Primitive("%put", PACKAGE_SYS, false)
2842 {
2843 public LispObject execute(LispObject symbol, LispObject indicator,
2844 LispObject value)
2845 throws ConditionThrowable
2846 {
2847 return put(checkSymbol(symbol), indicator, value);
2848 }
2849 public LispObject execute(LispObject symbol, LispObject indicator,
2850 LispObject defaultValue, LispObject value)
2851 throws ConditionThrowable
2852 {
2853 return put(checkSymbol(symbol), indicator, value);
2854 }
2855 };
2856
2857 private static final SpecialOperator MACROLET = new SpecialOperator("macrolet", "definitions &rest body")
2859 {
2860 public LispObject execute(LispObject args, Environment env)
2861 throws ConditionThrowable
2862 {
2863 LispObject defs = checkList(args.car());
2864 final LispThread thread = LispThread.currentThread();
2865 LispObject result;
2866 if (defs != NIL) {
2867 Environment ext = new Environment(env);
2868 while (defs != NIL) {
2869 LispObject def = checkList(defs.car());
2870 Symbol symbol = checkSymbol(def.car());
2871 LispObject lambdaList = def.cadr();
2872 LispObject body = def.cddr();
2873 LispObject block =
2874 new Cons(Symbol.BLOCK, new Cons(symbol, body));
2875 LispObject toBeApplied =
2876 list3(Symbol.LAMBDA, lambdaList, block);
2877 LispObject formArg = gensym("FORM-");
2878 LispObject envArg = gensym("ENV-"); LispObject expander =
2880 list3(Symbol.LAMBDA, list2(formArg, envArg),
2881 list3(Symbol.APPLY, toBeApplied,
2882 list2(Symbol.CDR, formArg)));
2883 Closure expansionFunction =
2884 new Closure(expander.cadr(), expander.cddr(), env);
2885 MacroObject macroObject =
2886 new MacroObject(expansionFunction);
2887 ext.bindFunctional(symbol, macroObject);
2888 defs = defs.cdr();
2889 }
2890 result = progn(args.cdr(), ext, thread);
2891 } else
2892 result = progn(args.cdr(), env, thread);
2893 return result;
2894 }
2895 };
2896
2897 private static final SpecialOperator TAGBODY = new SpecialOperator("tagbody", "&rest statements")
2899 {
2900 public LispObject execute(LispObject args, Environment env)
2901 throws ConditionThrowable
2902 {
2903 Environment ext = new Environment(env);
2904 LispObject localTags = NIL; LispObject body = args;
2906 while (body != NIL) {
2907 LispObject current = body.car();
2908 body = body.cdr();
2909 if (current instanceof Cons)
2910 continue;
2911 ext.addTagBinding(current, body);
2913 localTags = new Cons(current, localTags);
2914 }
2915 final LispThread thread = LispThread.currentThread();
2916 final LispObject stack = thread.getStack();
2917 LispObject remaining = args;
2918 while (remaining != NIL) {
2919 LispObject current = remaining.car();
2920 if (current instanceof Cons) {
2921 try {
2922 if (current.car() == Symbol.GO) {
2924 if (interrupted)
2925 handleInterrupt();
2926 LispObject tag = current.cadr();
2927 if (memql(tag, localTags)) {
2928 Binding binding = ext.getTagBinding(tag);
2929 if (binding != null && binding.value != null) {
2930 remaining = binding.value;
2931 continue;
2932 }
2933 }
2934 throw new Go(tag);
2935 }
2936 eval(current, ext, thread);
2937 }
2938 catch (Go go) {
2939 LispObject tag = go.getTag();
2940 if (memql(tag, localTags)) {
2941 Binding binding = ext.getTagBinding(tag);
2942 if (binding != null && binding.value != null) {
2943 remaining = binding.value;
2944 thread.setStack(stack);
2945 continue;
2946 }
2947 }
2948 throw go;
2949 }
2950 }
2951 remaining = remaining.cdr();
2952 }
2953 thread.clearValues();
2954 return NIL;
2955 }
2956 };
2957
2958 private static final SpecialOperator GO = new SpecialOperator("go", "tag")
2960 {
2961 public LispObject execute(LispObject args, Environment env)
2962 throws ConditionThrowable
2963 {
2964 if (args.length() != 1)
2965 signal(new WrongNumberOfArgumentsException(this));
2966 Binding binding = env.getTagBinding(args.car());
2967 if (binding == null)
2968 return signal(new ControlError("No tag named " +
2969 args.car().writeToString() +
2970 " is currently visible."));
2971 throw new Go(args.car());
2972 }
2973 };
2974
2975 private static final SpecialOperator BLOCK = new SpecialOperator("block", "name &rest forms")
2977 {
2978 public LispObject execute(LispObject args, Environment env)
2979 throws ConditionThrowable
2980 {
2981 if (args == NIL)
2982 signal(new WrongNumberOfArgumentsException(this));
2983 LispObject tag;
2984 try {
2985 tag = (Symbol) args.car();
2986 }
2987 catch (ClassCastException e) {
2988 return signal(new TypeError(args.car(), Symbol.SYMBOL));
2989 }
2990 LispObject body = args.cdr();
2991 Environment ext = new Environment(env);
2992 final LispObject block = new LispObject();
2993 ext.addBlock(tag, block);
2994 LispObject result = NIL;
2995 final LispThread thread = LispThread.currentThread();
2996 final LispObject stack = thread.getStack();
2997 try {
2998 while (body != NIL) {
2999 result = eval(body.car(), ext, thread);
3000 body = body.cdr();
3001 }
3002 return result;
3003 }
3004 catch (Return ret) {
3005 if (ret.getBlock() == block) {
3006 thread.setStack(stack);
3007 return ret.getResult();
3008 }
3009 throw ret;
3010 }
3011 }
3012 };
3013
3014 private static final SpecialOperator RETURN_FROM =
3016 new SpecialOperator("return-from", "name &optional value")
3017 {
3018 public LispObject execute(LispObject args, Environment env)
3019 throws ConditionThrowable
3020 {
3021 final int length = args.length();
3022 if (length < 1 || length > 2)
3023 signal(new WrongNumberOfArgumentsException(this));
3024 LispObject symbol;
3025 try {
3026 symbol = (Symbol) args.car();
3027 }
3028 catch (ClassCastException e) {
3029 return signal(new TypeError(args.car(), Symbol.SYMBOL));
3030 }
3031 LispObject block = env.lookupBlock(symbol);
3032 if (block == null) {
3033 StringBuffer sb = new StringBuffer ("No block named ");
3034 sb.append(symbol.getName());
3035 sb.append(" is currently visible.");
3036 signal(new LispError(sb.toString()));
3037 }
3038 LispObject result;
3039 if (length == 2)
3040 result = eval(args.cadr(), env, LispThread.currentThread());
3041 else
3042 result = NIL;
3043 throw new Return(symbol, block, result);
3044 }
3045 };
3046
3047 private static final SpecialOperator CATCH = new SpecialOperator("catch", "tag &body body")
3049 {
3050 public LispObject execute(LispObject args, Environment env)
3051 throws ConditionThrowable
3052 {
3053 if (args.length() < 1)
3054 signal(new WrongNumberOfArgumentsException(this));
3055 final LispThread thread = LispThread.currentThread();
3056 LispObject tag = eval(args.car(), env, thread);
3057 thread.pushCatchTag(tag);
3058 LispObject body = args.cdr();
3059 LispObject result = NIL;
3060 final LispObject stack = thread.getStack();
3061 try {
3062 while (body != NIL) {
3063 result = eval(body.car(), env, thread);
3064 body = body.cdr();
3065 }
3066 return result;
3067 }
3068 catch (Throw t) {
3069 if (t.tag == tag) {
3070 thread.setStack(stack);
3071 return t.getResult(thread);
3072 }
3073 throw t;
3074 }
3075 catch (Return ret) {
3076 throw ret;
3077 }
3078 finally {
3079 thread.popCatchTag();
3080 }
3081 }
3082 };
3083
3084 private static final SpecialOperator THROW = new SpecialOperator("throw", "tag result")
3086 {
3087 public LispObject execute(LispObject args, Environment env)
3088 throws ConditionThrowable
3089 {
3090 if (args.length() != 2)
3091 signal(new WrongNumberOfArgumentsException(this));
3092 final LispThread thread = LispThread.currentThread();
3093 thread.throwToTag(eval(args.car(), env, thread),
3094 eval(args.cadr(), env, thread));
3095 return NIL;
3097 }
3098 };
3099
3100 private static final SpecialOperator UNWIND_PROTECT =
3102 new SpecialOperator("unwind-protect", "protected &body cleanup")
3103 {
3104 public LispObject execute(LispObject args, Environment env)
3105 throws ConditionThrowable
3106 {
3107 final LispThread thread = LispThread.currentThread();
3108 LispObject result;
3109 LispObject[] values;
3110 try {
3111 result = eval(args.car(), env, thread);
3112 values = thread.getValues();
3113 }
3114 finally {
3115 LispObject body = args.cdr();
3116 while (body != NIL) {
3117 eval(body.car(), env, thread);
3118 body = body.cdr();
3119 }
3120 }
3121 if (values != null)
3122 thread.setValues(values);
3123 else
3124 thread.clearValues();
3125 return result;
3126 }
3127 };
3128
3129 private static final SpecialOperator EVAL_WHEN =
3131 new SpecialOperator("eval-when", "situations &rest forms")
3132 {
3133 public LispObject execute(LispObject args, Environment env)
3134 throws ConditionThrowable
3135 {
3136 LispObject situations = args.car();
3137 if (situations != NIL) {
3138 final LispThread thread = LispThread.currentThread();
3139 if (memq(Keyword.EXECUTE, situations) ||
3140 memq(Symbol.EVAL, situations))
3141 {
3142 return progn(args.cdr(), env, thread);
3143 }
3144 }
3145 return NIL;
3146 }
3147 };
3148
3149 private static final SpecialOperator MULTIPLE_VALUE_BIND =
3153 new SpecialOperator("multiple-value-bind", "vars value-form &body body") {
3154 public LispObject execute(LispObject args, Environment env)
3155 throws ConditionThrowable
3156 {
3157 LispObject vars = args.car();
3158 args = args.cdr();
3159 LispObject valuesForm = args.car();
3160 LispObject body = args.cdr();
3161 final LispThread thread = LispThread.currentThread();
3162 LispObject value = eval(valuesForm, env, thread);
3163 LispObject[] values = thread.getValues();
3164 if (values == null) {
3165 values = new LispObject[1];
3167 values[0] = value;
3168 }
3169 LispObject specials = NIL;
3171 while (body != NIL) {
3172 LispObject obj = body.car();
3173 if (obj instanceof Cons && obj.car() == Symbol.DECLARE) {
3174 LispObject decls = obj.cdr();
3175 while (decls != NIL) {
3176 LispObject decl = decls.car();
3177 if (decl instanceof Cons && decl.car() == Symbol.SPECIAL) {
3178 LispObject declvars = decl.cdr();
3179 while (declvars != NIL) {
3180 specials = new Cons(declvars.car(), specials);
3181 declvars = declvars.cdr();
3182 }
3183 }
3184 decls = decls.cdr();
3185 }
3186 body = body.cdr();
3187 } else
3188 break;
3189 }
3190 final Environment oldDynEnv = thread.getDynamicEnvironment();
3191 final Environment ext = new Environment(env);
3192 int i = 0;
3193 LispObject var = vars.car();
3194 while (var != NIL) {
3195 Symbol sym = checkSymbol(var);
3196 LispObject val = i < values.length ? values[i] : NIL;
3197 if (specials != NIL && memq(sym, specials)) {
3198 thread.bindSpecial(sym, val);
3199 ext.declareSpecial(sym);
3200 } else if (sym.isSpecialVariable()) {
3201 thread.bindSpecial(sym, val);
3202 } else
3203 ext.bind(sym, val);
3204 vars = vars.cdr();
3205 var = vars.car();
3206 ++i;
3207 }
3208 thread._values = null;
3209 LispObject result = NIL;
3210 try {
3211 while (body != NIL) {
3212 result = eval(body.car(), ext, thread);
3213 body = body.cdr();
3214 }
3215 }
3216 finally {
3217 thread.setDynamicEnvironment(oldDynEnv);
3218 }
3219 return result;
3220 }
3221 };
3222
3223 private static final SpecialOperator MULTIPLE_VALUE_PROG1 =
3225 new SpecialOperator("multiple-value-prog1", "values-form &rest forms")
3226 {
3227 public LispObject execute(LispObject args, Environment env)
3228 throws ConditionThrowable
3229 {
3230 if (args.length() == 0)
3231 signal(new WrongNumberOfArgumentsException(this));
3232 final LispThread thread = LispThread.currentThread();
3233 LispObject result = eval(args.car(), env, thread);
3234 LispObject[] values = thread.getValues();
3235 while ((args = args.cdr()) != NIL)
3236 eval(args.car(), env, thread);
3237 if (values != null)
3238 thread.setValues(values);
3239 else
3240 thread.clearValues();
3241 return result;
3242 }
3243 };
3244
3245 private static final SpecialOperator MULTIPLE_VALUE_CALL =
3247 new SpecialOperator("multiple-value-call", "fun &rest args")
3248 {
3249 public LispObject execute(LispObject args, Environment env)
3250 throws ConditionThrowable
3251 {
3252 if (args.length() == 0)
3253 signal(new WrongNumberOfArgumentsException(this));
3254 final LispThread thread = LispThread.currentThread();
3255 LispObject function;
3256 LispObject obj = eval(args.car(), env, thread);
3257 args = args.cdr();
3258 if (obj instanceof Symbol) {
3259 function = obj.getSymbolFunction();
3260 if (function == null)
3261 signal(new UndefinedFunction(obj));
3262 } else if (obj instanceof Function) {
3263 function = obj;
3264 } else {
3265 signal(new LispError(obj.writeToString() +
3266 " is not a function name."));
3267 return NIL;
3268 }
3269 ArrayList arrayList = new ArrayList ();
3270 while (args != NIL) {
3271 LispObject form = args.car();
3272 LispObject result = eval(form, env, thread);
3273 LispObject[] values = thread.getValues();
3274 if (values != null) {
3275 for (int i = 0; i < values.length; i++)
3276 arrayList.add(values[i]);
3277 } else
3278 arrayList.add(result);
3279 args = args.cdr();
3280 }
3281 LispObject[] argv = new LispObject[arrayList.size()];
3282 arrayList.toArray(argv);
3283 return funcall(function, argv, thread);
3284 }
3285 };
3286
3287 private static final SpecialOperator AND = new SpecialOperator("and", "&rest forms") {
3290 public LispObject execute(LispObject args, Environment env)
3291 throws ConditionThrowable
3292 {
3293 final LispThread thread = LispThread.currentThread();
3294 LispObject result = T;
3295 while (args != NIL) {
3296 result = eval(args.car(), env, thread);
3297 if (result == NIL) {
3298 if (args.cdr() != NIL) {
3299 thread.clearValues();
3301 }
3302 break;
3303 }
3304 args = args.cdr();
3305 }
3306 return result;
3307 }
3308 };
3309
3310 private static final SpecialOperator OR = new SpecialOperator("or", "&rest forms") {
3313 public LispObject execute(LispObject args, Environment env)
3314 throws ConditionThrowable
3315 {
3316 final LispThread thread = LispThread.currentThread();
3317 LispObject result = NIL;
3318 while (args != NIL) {
3319 result = eval(args.car(), env, thread);
3320 if (result != NIL) {
3321 if (args.cdr() != NIL) {
3322 thread.clearValues();
3324 }
3325 break;
3326 }
3327 args = args.cdr();
3328 }
3329 return result;
3330 }
3331 };
3332
3333 private static final Primitive2 _WRITE_CHAR =
3336 new Primitive2("%write-char", PACKAGE_SYS, false,
3337 "character output-stream")
3338 {
3339 public LispObject execute(LispObject first, LispObject second)
3340 throws ConditionThrowable
3341 {
3342 outSynonymOf(second)._writeChar(LispCharacter.getValue(first));
3343 return first;
3344 }
3345 };
3346
3347 private static final Primitive4 _WRITE_STRING =
3350 new Primitive4("%write-string", PACKAGE_SYS, false,
3351 "string output-stream start end")
3352 {
3353 public LispObject execute(LispObject first, LispObject second,
3354 LispObject third, LispObject fourth)
3355 throws ConditionThrowable
3356 {
3357 AbstractString s;
3358 try {
3359 s = (AbstractString) first;
3360 }
3361 catch (ClassCastException e) {
3362 return signal(new TypeError(first, Symbol.STRING));
3363 }
3364 char[] chars = s.chars();
3365 Stream out = outSynonymOf(second);
3366 int start = Fixnum.getValue(third);
3367 int end;
3368 if (fourth == NIL)
3369 end = chars.length;
3370 else
3371 end = Fixnum.getValue(fourth);
3372 checkBounds(start, end, chars.length);
3373 out._writeChars(chars, start, end);
3374 return first;
3375 }
3376 };
3377
3378 private static final Primitive1 _FINISH_OUTPUT =
3380 new Primitive1("%finish-output", PACKAGE_SYS, false, "output-stream")
3381 {
3382 public LispObject execute(LispObject arg) throws ConditionThrowable
3383 {
3384 return finishOutput(arg);
3385 }
3386 };
3387
3388 private static final Primitive1 _FORCE_OUTPUT =
3390 new Primitive1("%force-output", PACKAGE_SYS, false, "output-stream")
3391 {
3392 public LispObject execute(LispObject arg) throws ConditionThrowable
3393 {
3394 return finishOutput(arg);
3395 }
3396 };
3397
3398 private static final LispObject finishOutput(LispObject arg)
3399 throws ConditionThrowable
3400 {
3401 Stream out = null;
3402 if (arg == T)
3403 out = checkCharacterOutputStream(_TERMINAL_IO_.symbolValue());
3404 else if (arg == NIL)
3405 out = checkCharacterOutputStream(_STANDARD_OUTPUT_.symbolValue());
3406 else if (arg instanceof Stream) {
3407 Stream stream = (Stream) arg;
3408 if (stream instanceof TwoWayStream)
3409 out = ((TwoWayStream)arg).getOutputStream();
3410 else if (stream.isOutputStream())
3411 out = stream;
3412 }
3413 if (out == null)
3414 signal(new TypeError(arg, "output stream"));
3415 return out.finishOutput();
3416 }
3417
3418 private static final Primitive CLEAR_INPUT =
3421 new Primitive("clear-input", "&optional input-stream")
3422 {
3423 public LispObject execute(LispObject[] args) throws ConditionThrowable
3424 {
3425 if (args.length > 1)
3426 signal(new WrongNumberOfArgumentsException(this));
3427 final Stream in;
3428 if (args.length == 0)
3429 in = checkCharacterInputStream(_STANDARD_INPUT_.symbolValue());
3430 else
3431 in = inSynonymOf(args[0]);
3432 in.clearInput();
3433 return NIL;
3434 }
3435 };
3436
3437 private static final Primitive1 _CLEAR_OUTPUT =
3441 new Primitive1("%clear-output", PACKAGE_SYS, false, "output-stream")
3442 {
3443 public LispObject execute(LispObject arg) throws ConditionThrowable
3444 {
3445 if (arg == T)
3446 return NIL; if (arg == NIL)
3448 return NIL; if (arg instanceof Stream) {
3450 Stream stream = (Stream) arg;
3451 if (stream instanceof TwoWayStream) {
3452 Stream out = ((TwoWayStream)stream).getOutputStream();
3453 if (out.isOutputStream())
3454 return NIL;
3455 }
3456 if (stream.isOutputStream())
3457 return NIL;
3458 }
3459 return signal(new TypeError(arg, "output stream"));
3460 }
3461 };
3462
3463 private static final Primitive CLOSE =
3466 new Primitive("close", "stream &key abort")
3467 {
3468 public LispObject execute(LispObject[] args) throws ConditionThrowable
3469 {
3470 final int length = args.length;
3471 if (length == 0)
3472 signal(new WrongNumberOfArgumentsException(this));
3473 LispObject abort = NIL; Stream stream = checkStream(args[0]);
3475 if (length > 1) {
3476 if ((length - 1) % 2 != 0)
3477 signal(new ProgramError("Odd number of keyword arguments."));
3478 if (length > 3)
3479 signal(new WrongNumberOfArgumentsException(this));
3480 if (args[1] == Keyword.ABORT)
3481 abort = args[2];
3482 else
3483 signal(new ProgramError("Unrecognized keyword argument " +
3484 args[1].writeToString() + "."));
3485 }
3486 return stream.close(abort);
3487 }
3488 };
3489
3490 private static final SpecialOperator MULTIPLE_VALUE_LIST =
3495 new SpecialOperator("multiple-value-list", "value-form")
3496 {
3497 public LispObject execute(LispObject args, Environment env)
3498 throws ConditionThrowable
3499 {
3500 if (args.length() != 1)
3501 signal(new WrongNumberOfArgumentsException(this));
3502 final LispThread thread = LispThread.currentThread();
3503 LispObject result = eval(args.car(), env, thread);
3504 LispObject[] values = thread.getValues();
3505 if (values == null)
3506 return new Cons(result);
3507 thread.clearValues();
3508 LispObject list = NIL;
3509 for (int i = values.length; i-- > 0;)
3510 list = new Cons(values[i], list);
3511 return list;
3512 }
3513 };
3514
3515 private static final SpecialOperator NTH_VALUE =
3521 new SpecialOperator("nth-value", "n form")
3522 {
3523 public LispObject execute(LispObject args, Environment env)
3524 throws ConditionThrowable
3525 {
3526 if (args.length() != 2)
3527 signal(new WrongNumberOfArgumentsException(this));
3528 final LispThread thread = LispThread.currentThread();
3529 int n = Fixnum.getInt(eval(args.car(), env, thread));
3530 if (n < 0)
3531 n = 0;
3532 LispObject result = eval(args.cadr(), env, thread);
3533 LispObject[] values = thread.getValues();
3534 thread.clearValues();
3535 if (values == null) {
3536 return n == 0 ? result : NIL;
3538 }
3539 if (n < values.length)
3540 return values[n];
3541 return NIL;
3542 }
3543 };
3544
3545 private static final Primitive2 WRITE_8_BITS =
3548 new Primitive2("write-8-bits", PACKAGE_SYS, false, "byte stream")
3549 {
3550 public LispObject execute (LispObject first, LispObject second)
3551 throws ConditionThrowable
3552 {
3553 int n;
3554 try {
3555 n = ((Fixnum)first).value;
3556 }
3557 catch (ClassCastException e) {
3558 return signal(new TypeError(first, Symbol.FIXNUM));
3559 }
3560 if (n < 0 || n > 255)
3561 signal(new TypeError(first,
3562 list2(Symbol.UNSIGNED_BYTE, new Fixnum(8))));
3563 checkBinaryOutputStream(second)._writeByte(n);
3564 return first;
3565 }
3566 };
3567
3568 private static final Primitive READ_8_BITS =
3571 new Primitive("read-8-bits", PACKAGE_SYS, false,
3572 "stream &optional eof-error-p eof-value")
3573 {
3574 public LispObject execute (LispObject[] args) throws ConditionThrowable
3575 {
3576 int length = args.length;
3577 if (length < 1 || length > 3)
3578 signal(new WrongNumberOfArgumentsException(this));
3579 final Stream in = checkBinaryInputStream(args[0]);
3580 boolean eofError = length > 1 ? (args[1] != NIL) : true;
3581 LispObject eofValue = length > 2 ? args[2] : NIL;
3582 return in.readByte(eofError, eofValue);
3583 }
3584 };
3585
3586 private static final Primitive READ_LINE =
3590 new Primitive("read-line",
3591 "&optional input-stream eof-error-p eof-value recursive-p")
3592 {
3593 public LispObject execute(LispObject[] args) throws ConditionThrowable
3594 {
3595 int length = args.length;
3596 if (length > 4)
3597 signal(new WrongNumberOfArgumentsException(this));
3598 Stream stream =
3599 length > 0 ? inSynonymOf(args[0]) : getStandardInput();
3600 boolean eofError = length > 1 ? (args[1] != NIL) : true;
3601 LispObject eofValue = length > 2 ? args[2] : NIL;
3602 boolean recursive = length > 3 ? (args[3] != NIL) : false;
3603 return stream.readLine(eofError, eofValue);
3604 }
3605 };
3606
3607 private static final Primitive _READ_FROM_STRING =
3611 new Primitive("%read-from-string", PACKAGE_SYS, false)
3612 {
3613 public LispObject execute(LispObject[] args) throws ConditionThrowable
3614 {
3615 if (args.length < 6)
3616 signal(new WrongNumberOfArgumentsException(this));
3617 String s = args[0].getStringValue();
3618 boolean eofError = args[1] != NIL;
3619 LispObject eofValue = args[2];
3620 LispObject start = args[3];
3621 LispObject end = args[4];
3622 boolean preserveWhitespace = args[5] != NIL;
3623 int startIndex, endIndex;
3624 if (start != NIL)
3625 startIndex = (int) Fixnum.getValue(start);
3626 else
3627 startIndex = 0;
3628 if (end != NIL)
3629 endIndex = (int) Fixnum.getValue(end);
3630 else
3631 endIndex = s.length();
3632 StringInputStream in =
3633 new StringInputStream(s, startIndex, endIndex);
3634 LispObject result;
3635 if (preserveWhitespace)
3636 result = in.readPreservingWhitespace(eofError, eofValue, false);
3637 else
3638 result = in.read(eofError, eofValue, false);
3639 return LispThread.currentThread().setValues(result,
3640 new Fixnum(in.getOffset()));
3641 }
3642 };
3643
3644 private static final Primitive1 _CALL_COUNT =
3645 new Primitive1("%call-count", PACKAGE_SYS, false)
3646 {
3647 public LispObject execute(LispObject arg) throws ConditionThrowable
3648 {
3649 return new Fixnum(arg.getCallCount());
3650 }
3651 };
3652
3653 private static final Primitive2 _SET_CALL_COUNT =
3654 new Primitive2("%set-call-count", PACKAGE_SYS, false)
3655 {
3656 public LispObject execute(LispObject first, LispObject second)
3657 throws ConditionThrowable
3658 {
3659 first.setCallCount(Fixnum.getValue(second));
3660 return second;
3661 }
3662 };
3663
3664 private static final Primitive READ =
3667 new Primitive("read",
3668 "&optional input-stream eof-error-p eof-value recursive-p")
3669 {
3670 public LispObject execute(LispObject[] args) throws ConditionThrowable
3671 {
3672 int length = args.length;
3673 if (length > 4)
3674 signal(new WrongNumberOfArgumentsException(this));
3675 Stream stream =
3676 length > 0 ? checkCharacterInputStream(args[0]) : getStandardInput();
3677 boolean eofError = length > 1 ? (args[1] != NIL) : true;
3678 LispObject eofValue = length > 2 ? args[2] : NIL;
3679 boolean recursive = length > 3 ? (args[3] != NIL) : false;
3680 return stream.read(eofError, eofValue, recursive);
3681 }
3682 };
3683
3684 private static final Primitive READ_PRESERVING_WHITESPACE =
3687 new Primitive("read-preserving-whitespace",
3688 "&optional input-stream eof-error-p eof-value recursive-p")
3689 {
3690 public LispObject execute(LispObject[] args) throws ConditionThrowable
3691 {
3692 int length = args.length;
3693 if (length > 4)
3694 signal(new WrongNumberOfArgumentsException(this));
3695 Stream stream =
3696 length > 0 ? checkCharacterInputStream(args[0]) : getStandardInput();
3697 boolean eofError = length > 1 ? (args[1] != NIL) : true;
3698 LispObject eofValue = length > 2 ? args[2] : NIL;
3699 boolean recursive = length > 3 ? (args[3] != NIL) : false;
3700 return stream.readPreservingWhitespace(eofError, eofValue, recursive);
3701 }
3702 };
3703
3704 private static final Primitive READ_CHAR =
3707 new Primitive("read-char",
3708 "&optional input-stream eof-error-p eof-value recursive-p")
3709 {
3710 public LispObject execute(LispObject[] args) throws ConditionThrowable
3711 {
3712 int length = args.length;
3713 if (length > 4)
3714 signal(new WrongNumberOfArgumentsException(this));
3715 Stream stream =
3716 length > 0 ? inSynonymOf(args[0]) : getStandardInput();
3717 boolean eofError = length > 1 ? (args[1] != NIL) : true;
3718 LispObject eofValue = length > 2 ? args[2] : NIL;
3719 boolean recursive = length > 3 ? (args[3] != NIL) : false;
3720 return stream.readChar(eofError, eofValue);
3721 }
3722 };
3723
3724 private static final Primitive UNREAD_CHAR =
3727 new Primitive("unread-char", "character &optional input-stream")
3728 {
3729 public LispObject execute(LispObject arg) throws ConditionThrowable
3730 {
3731 return getStandardInput().unreadChar(checkCharacter(arg));
3732 }
3733 public LispObject execute(LispObject first, LispObject second)
3734 throws ConditionThrowable
3735 {
3736 Stream stream = inSynonymOf(second);
3737 return stream.unreadChar(checkCharacter(first));
3738 }
3739 };
3740
3741 private static final Primitive2 _SET_LAMBDA_NAME =
3743 new Primitive2("%set-lambda-name", PACKAGE_SYS, false)
3744 {
3745 public LispObject execute(LispObject first, LispObject second)
3746 throws ConditionThrowable
3747 {
3748 if (first instanceof Function) {
3749 Function f = (Function) first;
3750 f.setLambdaName(second);
3751 return second;
3752 }
3753 return signal(new TypeError(first, "function"));
3754 }
3755 };
3756
3757 private static final Primitive2 SHRINK_VECTOR =
3762 new Primitive2("shrink-vector", PACKAGE_SYS, false)
3763 {
3764 public LispObject execute(LispObject first, LispObject second)
3765 throws ConditionThrowable
3766 {
3767 checkVector(first).shrink(Fixnum.getInt(second));
3768 return first;
3769 }
3770 };
3771
3772 private static final Primitive SUBSEQ =
3775 new Primitive("subseq", "sequence start &optional end")
3776 {
3777 public LispObject execute(LispObject first, LispObject second)
3778 throws ConditionThrowable
3779 {
3780 final int start = Fixnum.getValue(second);
3781 if (start < 0) {
3782 StringBuffer sb = new StringBuffer ("Bad start index (");
3783 sb.append(start);
3784 sb.append(") for SUBSEQ.");
3785 signal(new TypeError(sb.toString()));
3786 }
3787 if (first.listp())
3788 return list_subseq(first, start, -1);
3789 if (first.vectorp()) {
3790 AbstractVector v = (AbstractVector) first;
3791 return v.subseq(start, v.length());
3792 }
3793 return signal(new TypeError(first, Symbol.SEQUENCE));
3794 }
3795 public LispObject execute(LispObject first, LispObject second,
3796 LispObject third)
3797 throws ConditionThrowable
3798 {
3799 final int start = Fixnum.getValue(second);
3800 if (start < 0) {
3801 StringBuffer sb = new StringBuffer ("Bad start index (");
3802 sb.append(start);
3803 sb.append(").");
3804 signal(new TypeError(sb.toString()));
3805 }
3806 int end;
3807 if (third != NIL) {
3808 end = Fixnum.getValue(third);
3809 if (start > end) {
3810 StringBuffer sb = new StringBuffer ("Start index (");
3811 sb.append(start);
3812 sb.append(") is greater than end index (");
3813 sb.append(end);
3814 sb.append(") for SUBSEQ.");
3815 signal(new TypeError(sb.toString()));
3816 }
3817 } else
3818 end = -1;
3819 if (first.listp())
3820 return list_subseq(first, start, end);
3821 if (first.vectorp()) {
3822 AbstractVector v = (AbstractVector) first;
3823 if (end < 0)
3824 end = v.length();
3825 return v.subseq(start, end);
3826 }
3827 return signal(new TypeError(first, Symbol.SEQUENCE));
3828 }
3829 };
3830
3831 private static final LispObject list_subseq(LispObject list, int start,
3832 int end)
3833 throws ConditionThrowable
3834 {
3835 int index = 0;
3836 LispObject result = NIL;
3837 while (list != NIL) {
3838 if (end >= 0 && index == end)
3839 return result.nreverse();
3840 if (index++ >= start)
3841 result = new Cons(list.car(), result);
3842 list = list.cdr();
3843 }
3844 return result.nreverse();
3845 }
3846
3847 public static final Primitive2 EXPT =
3850 new Primitive2("expt", "base-number power-number")
3851 {
3852 public LispObject execute(LispObject base, LispObject power)
3853 throws ConditionThrowable
3854 {
3855 if (power.zerop()) {
3856 if (power instanceof Fixnum) {
3857 if (base instanceof LispFloat)
3858 return LispFloat.ONE;
3859 if (base instanceof Complex) {
3860 if (((Complex)base).getRealPart() instanceof LispFloat)
3861 return Complex.getInstance(LispFloat.ONE,
3862 LispFloat.ZERO);
3863 }
3864 return Fixnum.ONE;
3865 }
3866 if (power instanceof LispFloat) {
3867 return LispFloat.ONE;
3868 }
3869 }
3870 if (power instanceof Fixnum) {
3871 if (base.rationalp())
3872 return intexp(base, power);
3873 LispObject result;
3874 if (base instanceof LispFloat)
3875 result = LispFloat.ONE;
3876 else
3877 result = Fixnum.ONE;
3878 int pow = ((Fixnum)power).value;
3879 if (pow > 0) {
3880 for (int i = pow; i-- > 0;)
3881 result = result.multiplyBy(base);
3882 } else if (pow < 0) {
3883 for (int i = -pow; i-- > 0;)
3884 result = result.divideBy(base);
3885 }
3886 return result;
3887 }
3888 if (power instanceof LispFloat) {
3889 if (base instanceof Fixnum) {
3890 double d = Math.pow(((Fixnum)base).value,
3891 ((LispFloat)power).value);
3892 return new LispFloat(d);
3893 }
3894 if (base instanceof LispFloat) {
3895 double d = Math.pow(((LispFloat)base).value,
3896 ((LispFloat)power).value);
3897 return new LispFloat(d);
3898 }
3899 }
3900 if (power instanceof Ratio) {
3901 if (base instanceof Fixnum) {
3902 double d = Math.pow(((Fixnum)base).getValue(),
3903 ((Ratio)power).floatValue());
3904 return new LispFloat(d);
3905 }
3906 if (base instanceof LispFloat) {
3907 double d = Math.pow(((LispFloat)base).value,
3908 ((Ratio)power).floatValue());
3909 return new LispFloat(d);
3910 }
3911 }
3912 signal(new LispError("EXPT: unsupported case"));
3913 return NIL;
3914 }
3915 };
3916
3917 private static final LispObject intexp(LispObject base, LispObject power)
3919 throws ConditionThrowable
3920 {
3921 if (power.minusp()) {
3922 power = Fixnum.ZERO.subtract(power);
3923 return Fixnum.ONE.divideBy(intexp(base, power));
3924 }
3925 if (base.eql(Fixnum.TWO))
3926 return Fixnum.ONE.ash(power);
3927 LispObject nextn = power.ash(Fixnum.MINUS_ONE);
3928 LispObject total;
3929 if (power.oddp())
3930 total = base;
3931 else
3932 total = Fixnum.ONE;
3933 while (true) {
3934 if (nextn.zerop())
3935 return total;
3936 base = base.multiplyBy(base);
3937 power = nextn;
3938 nextn = power.ash(Fixnum.MINUS_ONE);
3939 if (power.oddp())
3940 total = base.multiplyBy(total);
3941 }
3942 }
3943
3944 private static final Primitive LIST = new Primitive("list", "&rest objects")
3946 {
3947 public LispObject execute(LispObject arg) throws ConditionThrowable
3948 {
3949 return new Cons(arg);
3950 }
3951 public LispObject execute(LispObject first, LispObject second)
3952 throws ConditionThrowable
3953 {
3954 return new Cons(first, new Cons(second));
3955 }
3956 public LispObject execute(LispObject first, LispObject second,
3957 LispObject third) throws ConditionThrowable
3958 {
3959 return new Cons(first, new Cons(second, new Cons(third)));
3960 }
3961 public LispObject execute(LispObject[] args) throws ConditionThrowable
3962 {
3963 LispObject result = NIL;
3964 for (int i = args.length; i-- > 0;)
3965 result = new Cons(args[i], result);
3966 return result;
3967 }
3968 };
3969
3970 private static final Primitive LIST_ = new Primitive("list*", "&rest objects")
3972 {
3973 public LispObject execute() throws ConditionThrowable
3974 {
3975 signal(new WrongNumberOfArgumentsException("LIST*"));
3976 return NIL;
3977 }
3978 public LispObject execute(LispObject arg) throws ConditionThrowable
3979 {
3980 return arg;
3981 }
3982 public LispObject execute(LispObject first, LispObject second)
3983 throws ConditionThrowable
3984 {
3985 return new Cons(first, second);
3986 }
3987 public LispObject execute(LispObject first, LispObject second,
3988 LispObject third) throws ConditionThrowable
3989 {
3990 return new Cons(first, new Cons(second, third));
3991 }
3992 public LispObject execute(LispObject[] args) throws ConditionThrowable
3993 {
3994 int i = args.length - 1;
3995 LispObject result = args[i];
3996 while (i-- > 0)
3997 result = new Cons(args[i], result);
3998 return result;
3999 }
4000 };
4001
4002 public static final Primitive1 NREVERSE = new Primitive1("nreverse", "sequence")
4004 {
4005 public LispObject execute (LispObject arg) throws ConditionThrowable
4006 {
4007 return arg.nreverse();
4008 }
4009 };
4010
4011 private static final Primitive2 NRECONC = new Primitive2("nreconc", "list tail")
4014 {
4015 public LispObject execute(LispObject list, LispObject obj)
4016 throws ConditionThrowable
4017 {
4018 if (list instanceof Cons) {
4019 LispObject list3 = list.cdr();
4020 if (list3 instanceof Cons) {
4021 if (list3.cdr() instanceof Cons) {
4022 LispObject list1 = list3;
4023 LispObject list2 = NIL;
4024 do {
4025 LispObject h = list3.cdr();
4026 list3.setCdr(list2);
4027 list2 = list3;
4028 list3 = h;
4029 } while (list3.cdr() instanceof Cons);
4030 list.setCdr(list2);
4031 list1.setCdr(list3);
4032 }
4033 LispObject h = list.car();
4034 list.setCar(list3.car());
4035 list3.setCar(h);
4036 list3.setCdr(obj);
4037 } else if (list3 == NIL) {
4038 list.setCdr(obj);
4039 } else
4040 signal(new TypeError(list3, Symbol.LIST));
4041 return list;
4042 } else
4043 return obj;
4044 }
4045 };
4046
4047 private static final Primitive1 REVERSE = new Primitive1("reverse", "sequence")
4049 {
4050 public LispObject execute(LispObject arg) throws ConditionThrowable
4051 {
4052 if (arg instanceof AbstractVector)
4053 return ((AbstractVector)arg).reverse();
4054 if (arg instanceof Cons) {
4055 LispObject result = NIL;
4056 while (arg != NIL) {
4057 result = new Cons(arg.car(), result);
4058 arg = arg.cdr();
4059 }
4060 return result;
4061 }
4062 if (arg == NIL)
4063 return NIL;
4064 signal(new TypeError(arg, "proper sequence"));
4065 return NIL;
4066 }
4067 };
4068
4069 private static final Primitive3 _SET_ELT =
4072 new Primitive3("%set-elt", PACKAGE_SYS, false)
4073 {
4074 public LispObject execute(LispObject first, LispObject second,
4075 LispObject third)
4076 throws ConditionThrowable
4077 {
4078 if (first instanceof AbstractVector) {
4079 ((AbstractVector)first).setRowMajor(Fixnum.getValue(second), third);
4080 return third;
4081 }
4082 if (first instanceof Cons) {
4083 int index = Fixnum.getValue(second);
4084 if (index < 0)
4085 signal(new TypeError());
4086 LispObject list = first;
4087 int i = 0;
4088 while (true) {
4089 if (i == index) {
4090 list.setCar(third);
4091 return third;
4092 }
4093 list = list.cdr();
4094 if (list == NIL)
4095 signal(new TypeError());
4096 ++i;
4097 }
4098 }
4099 signal(new TypeError(first, Symbol.SEQUENCE));
4100 return NIL;
4101 }
4102 };
4103
4104
4113 private static final Primitive2 MAPTREE =
4115 new Primitive2("maptree", PACKAGE_SYS, false)
4116 {
4117 public LispObject execute(LispObject fun, LispObject x)
4118 throws ConditionThrowable
4119 {
4120 if (x instanceof Cons) {
4121 LispObject a = fun.execute(x.car());
4122 LispObject d = execute(fun, x.cdr());
4124 if (a.eql(x.car()) && d.eql(x.cdr()))
4125 return x;
4126 else
4127 return new Cons(a, d);
4128 } else
4129 return fun.execute(x);
4130 }
4131 };
4132
4133 private static final Primitive2 _MAKE_LIST =
4135 new Primitive2("%make-list", PACKAGE_SYS, false) {
4136 public LispObject execute(LispObject first, LispObject second)
4137 throws ConditionThrowable
4138 {
4139 int size = Fixnum.getValue(first);
4140 if (size < 0)
4141 signal(new TypeError(String.valueOf(size) +
4142 " is not a valid list length."));
4143 LispObject result = NIL;
4144 for (int i = size; i-- > 0;)
4145 result = new Cons(second, result);
4146 return result;
4147 }
4148 };
4149
4150 private static final Primitive _MEMBER =
4153 new Primitive("%member", PACKAGE_SYS, false) {
4154 public LispObject execute(LispObject[] args) throws ConditionThrowable
4155 {
4156 if (args.length != 5)
4157 signal(new WrongNumberOfArgumentsException(this));
4158 LispObject item = args[0];
4159 LispObject tail = checkList(args[1]);
4160 LispObject key = args[2];
4161 if (key != NIL) {
4162 if (key instanceof Symbol)
4163 key = key.getSymbolFunction();
4164 if (!(key instanceof Function || key instanceof GenericFunction))
4165 signal(new UndefinedFunction(args[2]));
4166 }
4167 LispObject test = args[3];
4168 LispObject testNot = args[4];
4169 if (test != NIL && testNot != NIL)
4170 signal(new LispError("MEMBER: test and test-not both supplied"));
4171 if (test == NIL && testNot == NIL) {
4172 test = EQL;
4173 } else if (test != NIL) {
4174 if (test instanceof Symbol)
4175 test = test.getSymbolFunction();
4176 if (!(test instanceof Function || test instanceof GenericFunction))
4177 signal(new UndefinedFunction(args[3]));
4178 } else if (testNot != NIL) {
4179 if (testNot instanceof Symbol)
4180 testNot = testNot.getSymbolFunction();
4181 if (!(testNot instanceof Function || testNot instanceof GenericFunction))
4182 signal(new UndefinedFunction(args[3]));
4183 }
4184 if (key == NIL && test == EQL) {
4185 while (tail != NIL) {
4186 if (item.eql(tail.car()))
4187 return tail;
4188 tail = tail.cdr();
4189 }
4190 return NIL;
4191 }
4192 while (tail != NIL) {
4193 LispObject candidate = tail.car();
4194 if (key != NIL)
4195 candidate = key.execute(candidate);
4196 if (test != NIL) {
4197 if (test.execute(item, candidate) == T)
4198 return tail;
4199 } else if (testNot != NIL) {
4200 if (testNot.execute(item, candidate) == NIL)
4201 return tail;
4202 }
4203 tail = tail.cdr();
4204 }
4205 return NIL;
4206 }
4207 };
4208
4209 private static final Primitive2 FUNCALL_KEY =
4212 new Primitive2("funcall-key", PACKAGE_SYS, false) {
4213 public LispObject execute(LispObject first, LispObject second)
4214 throws ConditionThrowable
4215 {
4216 if (first != NIL)
4217 return funcall1(first, second, LispThread.currentThread());
4218 return second;
4219 }
4220 };
4221
4222 private static final Primitive1 COERCE_TO_FUNCTION =
4224 new Primitive1("coerce-to-function", PACKAGE_SYS, false)
4225 {
4226 public LispObject execute(LispObject arg) throws ConditionThrowable
4227 {
4228 return coerceToFunction(arg);
4229 }
4230 };
4231
4232 private static final Primitive2 MAKE_CLOSURE =
4234 new Primitive2("make-closure", PACKAGE_SYS, false)
4235 {
4236 public LispObject execute(LispObject first, LispObject second)
4237 throws ConditionThrowable
4238 {
4239 if (first instanceof Cons && first.car() == Symbol.LAMBDA) {
4240 final Environment env;
4241 if (second == NIL)
4242 env = new Environment();
4243 else
4244 env = checkEnvironment(second);
4245 return new Closure(first.cadr(), first.cddr(), env);
4246 }
4247 return signal(new TypeError("Argument to MAKE-CLOSURE is not a lambda form."));
4248 }
4249 };
4250
4251 private static final Primitive1 STREAMP = new Primitive1("streamp", "object")
4253 {
4254 public LispObject execute(LispObject arg)
4255 {
4256 return arg instanceof Stream ? T : NIL;
4257 }
4258 };
4259
4260 private static final Primitive1 INTEGERP = new Primitive1("integerp", "object")
4262 {
4263 public LispObject execute(LispObject arg)
4264 {
4265 return arg.INTEGERP();
4266 }
4267 };
4268
4269 private static final Primitive1 EVENP = new Primitive1("evenp", "integer")
4271 {
4272 public LispObject execute(LispObject arg) throws ConditionThrowable
4273 {
4274 return arg.EVENP();
4275 }
4276 };
4277
4278 private static final Primitive1 ODDP = new Primitive1("oddp", "integer")
4280 {
4281 public LispObject execute(LispObject arg) throws ConditionThrowable
4282 {
4283 return arg.ODDP();
4284 }
4285 };
4286
4287 private static final Primitive1 NUMBERP = new Primitive1("numberp", "object")
4289 {
4290 public LispObject execute(LispObject arg)
4291 {
4292 return arg.NUMBERP();
4293 }
4294 };
4295
4296 private static final Primitive1 REALP = new Primitive1("realp", "object")
4298 {
4299 public LispObject execute(LispObject arg)
4300 {
4301 return arg.REALP();
4302 }
4303 };
4304
4305 private static final Primitive1 RATIONALP = new Primitive1("rationalp","object") {
4307 public LispObject execute(LispObject arg)
4308 {
4309 return arg.RATIONALP();
4310 }
4311 };
4312
4313 private static final Primitive2 COMPLEX = new Primitive2("complex","realpart &optional imagpart") {
4315 public LispObject execute(LispObject arg) throws ConditionThrowable
4316 {
4317 if (arg instanceof LispFloat)
4318 return Complex.getInstance(arg, LispFloat.ZERO);
4319 if (arg.realp())
4320 return arg;
4321 signal(new TypeError(arg, "real number"));
4322 return NIL;
4323 }
4324 public LispObject execute(LispObject first, LispObject second)
4325 throws ConditionThrowable
4326 {
4327 return Complex.getInstance(first, second);
4328 }
4329 };
4330
4331 private static final Primitive1 COMPLEXP = new Primitive1("complexp","object") {
4333 public LispObject execute(LispObject arg)
4334 {
4335 return arg.COMPLEXP();
4336 }
4337 };
4338
4339 private static final Primitive1 NUMERATOR = new Primitive1("numerator","rational") {
4341 public LispObject execute(LispObject arg) throws ConditionThrowable
4342 {
4343 return arg.NUMERATOR();
4344 }
4345 };
4346
4347 private static final Primitive1 DENOMINATOR = new Primitive1("denominator","rational")
4349 {
4350 public LispObject execute(LispObject arg) throws ConditionThrowable
4351 {
4352 return arg.DENOMINATOR();
4353 }
4354 };
4355
4356 private static final Primitive1 REALPART = new Primitive1("realpart","number")
4358 {
4359 public LispObject execute(LispObject arg) throws ConditionThrowable
4360 {
4361 if (arg instanceof Complex)
4362 return ((Complex)arg).getRealPart();
4363 if (arg.numberp())
4364 return arg;
4365 signal(new TypeError(arg, "number"));
4366 return NIL;
4367 }
4368 };
4369
4370 private static final Primitive1 IMAGPART = new Primitive1("imagpart", "number")
4372 {
4373 public LispObject execute(LispObject arg) throws ConditionThrowable
4374 {
4375 if (arg instanceof Complex)
4376 return ((Complex)arg).getImaginaryPart();
4377 return arg.multiplyBy(Fixnum.ZERO);
4378 }
4379 };
4380
4381 private static final Primitive1 INTEGER_LENGTH =
4383 new Primitive1("integer-length", "integer")
4384 {
4385 public LispObject execute(LispObject arg) throws ConditionThrowable
4386 {
4387 if (arg instanceof Fixnum) {
4388 int n = ((Fixnum)arg).value;
4389 if (n < 0)
4390 n = ~n;
4391 int count = 0;
4392 while (n > 0) {
4393 n = n >>> 1;
4394 ++count;
4395 }
4396 return new Fixnum(count);
4397 }
4398 if (arg instanceof Bignum)
4399 return new Fixnum(((Bignum)arg).value.bitLength());
4400 return signal(new TypeError(arg, "integer"));
4401 }
4402 };
4403
4404 private static final Primitive2 GCD_2 =
4406 new Primitive2("gcd-2", PACKAGE_SYS, false)
4407 {
4408 public LispObject execute(LispObject first, LispObject second)
4409 throws ConditionThrowable
4410 {
4411 BigInteger n1, n2;
4412 if (first instanceof Fixnum)
4413 n1 = BigInteger.valueOf(((Fixnum)first).getValue());
4414 else if (first instanceof Bignum)
4415 n1 = ((Bignum)first).getValue();
4416 else {
4417 signal(new TypeError(first, "integer"));
4418 return NIL;
4419 }
4420 if (second instanceof Fixnum)
4421 n2 = BigInteger.valueOf(((Fixnum)second).getValue());
4422 else if (second instanceof Bignum)
4423 n2 = ((Bignum)second).getValue();
4424 else {
4425 signal(new TypeError(second, "integer"));
4426 return NIL;
4427 }
4428 return number(n1.gcd(n2));
4429 }
4430 };
4431
4432 private static final Primitive1 IDENTITY_HASH_CODE =
4434 new Primitive1("identity-hash-code", PACKAGE_SYS, false)
4435 {
4436 public LispObject execute(LispObject arg) throws ConditionThrowable
4437 {
4438 return new Fixnum(System.identityHashCode(arg));
4439 }
4440 };
4441
4442 private static final Primitive2 SIMPLE_VECTOR_SEARCH =
4445 new Primitive2("simple-vector-search", PACKAGE_SYS, false)
4446 {
4447 public LispObject execute(LispObject first, LispObject second)
4448 throws ConditionThrowable
4449 {
4450 AbstractVector v = checkVector(second);
4451 if (first.length() == 0)
4452 return Fixnum.ZERO;
4453 final int patternLength = first.length();
4454 final int limit = v.length() - patternLength;
4455 if (first instanceof AbstractVector) {
4456 AbstractVector pattern = (AbstractVector) first;
4457 LispObject element = pattern.getRowMajor(0);
4458 for (int i = 0; i <= limit; i++) {
4459 if (v.getRowMajor(i).eql(element)) {
4460 boolean match = true;
4462 int j = i + 1;
4464 for (int k = 1; k < patternLength; k++) {
4465 if (v.getRowMajor(j).eql(pattern.getRowMajor(k))) {
4466 ++j;
4467 } else {
4468 match = false;
4469 break;
4470 }
4471 }
4472 if (match)
4473 return new Fixnum(i);
4474 }
4475 }
4476 } else {
4477 LispObject element = first.car();
4479 for (int i = 0; i <= limit; i++) {
4480 if (v.getRowMajor(i).eql(element)) {
4481 boolean match = true;
4483 int j = i + 1;
4485 for (LispObject rest = first.cdr(); rest != NIL; rest = rest.cdr()) {
4486 if (v.getRowMajor(j).eql(rest.car())) {
4487 ++j;
4488 } else {
4489 match = false;
4490 break;
4491 }
4492 }
4493 if (match)
4494 return new Fixnum(i);
4495 }
4496 }
4497 }
4498 return NIL;
4499 }
4500 };
4501
4502 private static final Primitive0 UPTIME =
4504 new Primitive0("uptime", PACKAGE_EXT, true)
4505 {
4506 public LispObject execute() throws ConditionThrowable
4507 {
4508 return number(System.currentTimeMillis() - Main.startTimeMillis);
4509 }
4510 };
4511
4512 private static final Primitive1 BUILT_IN_FUNCTION_P =
4514 new Primitive1("built-in-function-p", PACKAGE_SYS, false)
4515 {
4516 public LispObject execute(LispObject arg) throws ConditionThrowable
4517 {
4518 try {
4519 return ((Symbol)arg).isBuiltInFunction() ? T : NIL;
4520 }
4521 catch (ClassCastException e) {
4522 return signal(new TypeError(arg, Symbol.SYMBOL));
4523 }
4524 }
4525 };
4526
4527 private static final Primitive1 INSPECTED_PARTS =
4529 new Primitive1("inspected-parts", PACKAGE_SYS, false)
4530 {
4531 public LispObject execute(LispObject arg) throws ConditionThrowable
4532 {
4533 return arg.getParts();
4534 }
4535 };
4536
4537 private static final Primitive1 INSPECTED_DESCRIPTION =
4539 new Primitive1("inspected-description", PACKAGE_SYS, false)
4540 {
4541 public LispObject execute(LispObject arg) throws ConditionThrowable
4542 {
4543 return arg.getDescription();
4544 }
4545 };
4546
4547 static {
4548 new Primitives();
4549 }
4550}
4551 |
Popular Tags |
Java API By Example, From Geeks To Geeks.