0001: /*
0002: * Primitives.java
0003: *
0004: * Copyright (C) 2002-2003 Peter Graves
0005: * $Id: Primitives.java,v 1.8 2003/11/15 11:03:33 beedlem Exp $
0006: *
0007: * This program is free software; you can redistribute it and/or
0008: * modify it under the terms of the GNU General Public License
0009: * as published by the Free Software Foundation; either version 2
0010: * of the License, or (at your option) any later version.
0011: *
0012: * This program is distributed in the hope that it will be useful,
0013: * but WITHOUT ANY WARRANTY; without even the implied warranty of
0014: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
0015: * GNU General Public License for more details.
0016: *
0017: * You should have received a copy of the GNU General Public License
0018: * along with this program; if not, write to the Free Software
0019: * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
0020: */
0021:
0022: package org.armedbear.lisp;
0023:
0024: import java.math.BigInteger;
0025: import java.util.ArrayList;
0026: import java.util.Iterator;
0027: import java.util.List;
0028: import java.util.Random;
0029:
0030: public final class Primitives extends Module {
0031: // Primitive
0032: private static final int DIVIDE = 1;
0033: private static final int MAX = 2;
0034: private static final int MIN = 3;
0035: private static final int MULTIPLY = 4;
0036: private static final int VALUES = 5;
0037:
0038: // Primitive1
0039: private static final int ABS = 6;
0040: private static final int ARRAYP = 7;
0041: private static final int ARRAY_HAS_FILL_POINTER_P = 8;
0042: private static final int BIT_VECTOR_P = 9;
0043: private static final int BOTH_CASE_P = 10;
0044: private static final int CHARACTERP = 11;
0045: private static final int CHAR_CODE = 12;
0046: private static final int CHAR_DOWNCASE = 13;
0047: private static final int CHAR_INT = 14;
0048: private static final int CHAR_UPCASE = 15;
0049: private static final int CODE_CHAR = 16;
0050: private static final int COMPILED_FUNCTION_P = 17;
0051: private static final int CONSP = 18;
0052: private static final int EVAL = 19;
0053: private static final int EVENP = 20;
0054: private static final int FOURTH = 21;
0055: private static final int IDENTITY = 22;
0056: private static final int KEYWORDP = 23;
0057: private static final int LENGTH = 24;
0058: private static final int LISTP = 25;
0059: private static final int LOWER_CASE_P = 26;
0060: private static final int MAKE_SYMBOL = 27;
0061: private static final int MAKUNBOUND = 28;
0062: private static final int NUMBERP = 29;
0063: private static final int ODDP = 30;
0064: private static final int PREDECESSOR = 31;
0065: private static final int SECOND = 32;
0066: private static final int SIMPLE_BIT_VECTOR_P = 33;
0067: private static final int SIMPLE_STRING_P = 34;
0068: private static final int SIMPLE_VECTOR_P = 35;
0069: private static final int SPECIAL_OPERATOR_P = 36;
0070: private static final int STRINGP = 37;
0071: private static final int SUCCESSOR = 38;
0072: private static final int SYMBOL_FUNCTION = 39;
0073: private static final int SYMBOL_NAME = 40;
0074: private static final int SYMBOL_PACKAGE = 41;
0075: private static final int SYMBOL_PLIST = 42;
0076: private static final int THIRD = 43;
0077: private static final int UPPER_CASE_P = 44;
0078: private static final int VALUES_LIST = 45;
0079: private static final int VECTORP = 46;
0080:
0081: // Primitive2
0082: private static final int MEMBER = 47;
0083: private static final int RPLACA = 48;
0084: private static final int RPLACD = 49;
0085: private static final int SET = 50;
0086:
0087: private Primitives() {
0088: definePrimitive("*", MULTIPLY);
0089: definePrimitive("/", DIVIDE);
0090: definePrimitive("max", MAX);
0091: definePrimitive("min", MIN);
0092: definePrimitive("values", VALUES);
0093:
0094: definePrimitive1("1+", SUCCESSOR);
0095: definePrimitive1("1-", PREDECESSOR);
0096: definePrimitive1("abs", ABS);
0097: definePrimitive1("array-has-fill-pointer-p",
0098: ARRAY_HAS_FILL_POINTER_P);
0099: definePrimitive1("arrayp", ARRAYP);
0100: definePrimitive1("bit-vector-p", BIT_VECTOR_P);
0101: definePrimitive1("both-case-p", BOTH_CASE_P);
0102: definePrimitive1("char-code", CHAR_CODE);
0103: definePrimitive1("char-downcase", CHAR_DOWNCASE);
0104: definePrimitive1("char-int", CHAR_INT);
0105: definePrimitive1("char-upcase", CHAR_UPCASE);
0106: definePrimitive1("characterp", CHARACTERP);
0107: definePrimitive1("code-char", CODE_CHAR);
0108: definePrimitive1("compiled-function-p", COMPILED_FUNCTION_P);
0109: definePrimitive1("consp", CONSP);
0110: definePrimitive1("eval", EVAL);
0111: definePrimitive1("evenp", EVENP);
0112: definePrimitive1("fourth", FOURTH);
0113: definePrimitive1("identity", IDENTITY);
0114: definePrimitive1("keywordp", KEYWORDP);
0115: definePrimitive1("length", LENGTH);
0116: definePrimitive1("listp", LISTP);
0117: definePrimitive1("lower-case-p", LOWER_CASE_P);
0118: definePrimitive1("make-symbol", MAKE_SYMBOL);
0119: definePrimitive1("makunbound", MAKUNBOUND);
0120: definePrimitive1("numberp", NUMBERP);
0121: definePrimitive1("oddp", ODDP);
0122: definePrimitive1("second", SECOND);
0123: definePrimitive1("simple-bit-vector-p", SIMPLE_BIT_VECTOR_P);
0124: definePrimitive1("simple-string-p", SIMPLE_STRING_P);
0125: definePrimitive1("simple-vector-p", SIMPLE_VECTOR_P);
0126: definePrimitive1("special-operator-p", SPECIAL_OPERATOR_P);
0127: definePrimitive1("stringp", STRINGP);
0128: definePrimitive1("symbol-function", SYMBOL_FUNCTION);
0129: definePrimitive1("symbol-name", SYMBOL_NAME);
0130: definePrimitive1("symbol-package", SYMBOL_PACKAGE);
0131: definePrimitive1("symbol-plist", SYMBOL_PLIST);
0132: definePrimitive1("third", THIRD);
0133: definePrimitive1("upper-case-p", UPPER_CASE_P);
0134: definePrimitive1("values-list", VALUES_LIST);
0135: definePrimitive1("vectorp", VECTORP);
0136:
0137: definePrimitive2("member", MEMBER);
0138: definePrimitive2("rplaca", RPLACA);
0139: definePrimitive2("rplacd", RPLACD);
0140: definePrimitive2("set", SET);
0141: }
0142:
0143: // Primitive
0144: public LispObject dispatch(LispObject[] args, int index)
0145: throws ConditionThrowable {
0146: switch (index) {
0147: case MULTIPLY: { // ### *
0148: LispObject result = Fixnum.ONE;
0149: for (int i = 0; i < args.length; i++)
0150: result = result.multiplyBy(args[i]);
0151: return result;
0152: }
0153: case DIVIDE: { // ### /
0154: if (args.length < 1)
0155: throw new ConditionThrowable(
0156: new WrongNumberOfArgumentsException("/"));
0157: if (args.length == 1)
0158: return Fixnum.ONE.divideBy(args[0]);
0159: LispObject result = args[0];
0160: for (int i = 1; i < args.length; i++)
0161: result = result.divideBy(args[i]);
0162: return result;
0163: }
0164: case MIN: { // ### min
0165: if (args.length < 1)
0166: throw new ConditionThrowable(
0167: new WrongNumberOfArgumentsException("MIN"));
0168: LispObject result = args[0];
0169: if (!result.realp())
0170: throw new ConditionThrowable(new TypeError(result,
0171: "real"));
0172: for (int i = 1; i < args.length; i++) {
0173: if (args[i].isLessThan(result))
0174: result = args[i];
0175: }
0176: return result;
0177: }
0178: case MAX: { // ### max
0179: if (args.length < 1)
0180: throw new ConditionThrowable(
0181: new WrongNumberOfArgumentsException("MAX"));
0182: LispObject result = args[0];
0183: if (!result.realp())
0184: throw new ConditionThrowable(new TypeError(result,
0185: "real"));
0186: for (int i = 1; i < args.length; i++) {
0187: if (args[i].isGreaterThan(result))
0188: result = args[i];
0189: }
0190: return result;
0191: }
0192: case VALUES: // ### values
0193: return values(args);
0194: default:
0195: Debug.trace("bad index " + index);
0196: throw new ConditionThrowable(
0197: new WrongNumberOfArgumentsException((String) null));
0198: }
0199: }
0200:
0201: // Primitive1
0202: public LispObject dispatch(LispObject arg, int index)
0203: throws ConditionThrowable {
0204: switch (index) {
0205: case IDENTITY: // ### identity
0206: return arg;
0207: case SECOND: // ### second
0208: return arg.cadr();
0209: case THIRD: // ### third
0210: return arg.cdr().cdr().car();
0211: case FOURTH: // ### fourth
0212: return arg.cdr().cdr().cdr().car();
0213: case COMPILED_FUNCTION_P: // ### compiled-function-p
0214: return arg.typep(Symbol.COMPILED_FUNCTION);
0215: case KEYWORDP: // ### keywordp
0216: if (arg instanceof Symbol) {
0217: if (((Symbol) arg).getPackage() == PACKAGE_KEYWORD)
0218: return T;
0219: }
0220: return NIL;
0221: case SPECIAL_OPERATOR_P: // ### special-operator-p
0222: return arg.getSymbolFunction() instanceof SpecialOperator ? T
0223: : NIL;
0224: case EVENP: // ### evenp
0225: return arg.EVENP();
0226: case ODDP: // ### oddp
0227: return arg.ODDP();
0228: case NUMBERP: // ### numberp
0229: return arg.NUMBERP();
0230: case LENGTH: // ### length
0231: return arg.LENGTH();
0232: case CONSP: // ### consp
0233: return arg instanceof Cons ? T : NIL;
0234: case LISTP: // ### listp
0235: return arg.LISTP();
0236: case MAKE_SYMBOL: // ### make-symbol
0237: return new Symbol(LispString.getValue(arg));
0238: case MAKUNBOUND: // ### makunbound
0239: checkSymbol(arg).setSymbolValue(null);
0240: return arg;
0241: case SYMBOL_NAME: // ### symbol-name
0242: if (arg.typep(Symbol.SYMBOL) != NIL)
0243: return new LispString(arg.getName());
0244: throw new ConditionThrowable(new TypeError(arg, "symbol"));
0245: case SYMBOL_PACKAGE: // ### symbol-package
0246: return checkSymbol(arg).getPackage();
0247: case SYMBOL_FUNCTION: { // ### symbol-function
0248: LispObject function = arg.getSymbolFunction();
0249: if (function != null)
0250: return function;
0251: throw new ConditionThrowable(new UndefinedFunction(arg));
0252: }
0253: case SYMBOL_PLIST: // ### symbol-plist
0254: try {
0255: return ((Symbol) arg).getPropertyList();
0256: } catch (ClassCastException e) {
0257: throw new ConditionThrowable(new TypeError(arg,
0258: "symbol"));
0259: }
0260: case ABS: // ### abs
0261: return arg.ABS();
0262: case ARRAYP: // ### arrayp
0263: return arg instanceof AbstractArray ? T : NIL;
0264: case ARRAY_HAS_FILL_POINTER_P: // ### array-has-fill-pointer-p
0265: if (arg instanceof AbstractVector)
0266: return ((AbstractVector) arg).getFillPointer() >= 0 ? T
0267: : NIL;
0268: if (arg instanceof AbstractArray)
0269: return NIL;
0270: throw new ConditionThrowable(new TypeError(arg, "array"));
0271: case VECTORP: // ### vectorp
0272: return arg.VECTORP();
0273: case SIMPLE_VECTOR_P: // ### simple-vector-p
0274: return arg.typep(Symbol.SIMPLE_VECTOR);
0275: case BIT_VECTOR_P: // ### bit-vector-p
0276: return arg.BIT_VECTOR_P();
0277: case SIMPLE_BIT_VECTOR_P: // ### simple-bit-vector-p
0278: return arg.typep(Symbol.SIMPLE_BIT_VECTOR);
0279: case CHAR_CODE: // ### char-code
0280: case CHAR_INT: // ### char-int
0281: return new Fixnum(LispCharacter.getValue(arg));
0282: case CODE_CHAR: // ### code-char
0283: if (arg instanceof Fixnum) {
0284: int n = Fixnum.getValue(arg);
0285: if (n < 128)
0286: return LispCharacter.getInstance((char) n);
0287: }
0288: return NIL;
0289: case CHARACTERP: // ### characterp
0290: return arg instanceof LispCharacter ? T : NIL;
0291: case BOTH_CASE_P: { // ### both-case-p
0292: char c = LispCharacter.getValue(arg);
0293: if (Character.isLowerCase(c) || Character.isUpperCase(c))
0294: return T;
0295: return NIL;
0296: }
0297: case LOWER_CASE_P: // ### lower-case-p
0298: return Character.isLowerCase(LispCharacter.getValue(arg)) ? T
0299: : NIL;
0300: case UPPER_CASE_P: // ### upper-case-p
0301: return Character.isUpperCase(LispCharacter.getValue(arg)) ? T
0302: : NIL;
0303: case CHAR_DOWNCASE: // ### char-downcase
0304: return LispCharacter.getInstance(Utilities
0305: .toLowerCase(LispCharacter.getValue(arg)));
0306: case CHAR_UPCASE: // ### char-upcase
0307: return LispCharacter.getInstance(Utilities
0308: .toUpperCase(LispCharacter.getValue(arg)));
0309: case STRINGP: // ### stringp
0310: return arg.STRINGP();
0311: case SIMPLE_STRING_P: // ### simple-string-p
0312: return arg.SIMPLE_STRING_P();
0313: case SUCCESSOR: // ### 1+
0314: return arg.incr();
0315: case PREDECESSOR: // ### 1-
0316: return arg.decr();
0317: case VALUES_LIST: // ### values-list
0318: return values(arg.copyToArray());
0319: case EVAL: // ### eval
0320: return eval(arg, new Environment(), LispThread
0321: .currentThread());
0322: default:
0323: Debug.trace("bad index " + index);
0324: throw new ConditionThrowable(
0325: new WrongNumberOfArgumentsException((String) null));
0326: }
0327: }
0328:
0329: // Primitive2
0330: public LispObject dispatch(LispObject first, LispObject second,
0331: int index) throws ConditionThrowable {
0332: switch (index) {
0333: case MEMBER: { // ### member
0334: // member item list &key key test test-not => tail
0335: // FIXME Support keyword arguments!
0336: LispObject rest = checkList(second);
0337: while (rest != NIL) {
0338: if (first.eql(rest.car()))
0339: return rest;
0340: rest = rest.cdr();
0341: }
0342: return NIL;
0343: }
0344: case RPLACA: // ### rplaca
0345: first.setCar(second);
0346: return first;
0347: case RPLACD: // ### rplacd
0348: first.setCdr(second);
0349: return first;
0350: case SET: // ### set
0351: checkSymbol(first).setSymbolValue(second);
0352: return second;
0353: default:
0354: Debug.trace("bad index " + index);
0355: throw new ConditionThrowable(
0356: new WrongNumberOfArgumentsException((String) null));
0357: }
0358: }
0359:
0360: // ### eq
0361: private static final Primitive2 EQ = new Primitive2("eq") {
0362: public LispObject execute(LispObject first, LispObject second)
0363: throws ConditionThrowable {
0364: return first == second ? T : NIL;
0365: }
0366: };
0367:
0368: // ### eql
0369: private static final Primitive2 EQL = new Primitive2("eql") {
0370: public LispObject execute(LispObject first, LispObject second)
0371: throws ConditionThrowable {
0372: return first.eql(second) ? T : NIL;
0373: }
0374: };
0375:
0376: // ### equal
0377: private static final Primitive2 EQUAL = new Primitive2("equal") {
0378: public LispObject execute(LispObject first, LispObject second)
0379: throws ConditionThrowable {
0380: return first.equal(second) ? T : NIL;
0381: }
0382: };
0383:
0384: // ### equalp
0385: private static final Primitive2 EQUALP = new Primitive2("equalp") {
0386: public LispObject execute(LispObject first, LispObject second)
0387: throws ConditionThrowable {
0388: return first.equalp(second) ? T : NIL;
0389: }
0390: };
0391:
0392: // ### cons
0393: private static final Primitive2 CONS = new Primitive2("cons") {
0394: public LispObject execute(LispObject first, LispObject second)
0395: throws ConditionThrowable {
0396: return new Cons(first, second);
0397: }
0398: };
0399:
0400: // ### elt
0401: private static final Primitive2 ELT = new Primitive2("elt") {
0402: public LispObject execute(LispObject first, LispObject second)
0403: throws ConditionThrowable {
0404: return first.elt(Fixnum.getValue(second));
0405: }
0406: };
0407:
0408: // ### atom
0409: private static final Primitive1 ATOM = new Primitive1("atom") {
0410: public LispObject execute(LispObject arg)
0411: throws ConditionThrowable {
0412: return arg instanceof Cons ? NIL : T;
0413: }
0414: };
0415:
0416: // ### constantp
0417: private static final Primitive CONSTANTP = new Primitive(
0418: "constantp") {
0419: public LispObject execute(LispObject arg)
0420: throws ConditionThrowable {
0421: return arg.CONSTANTP();
0422: }
0423:
0424: public LispObject execute(LispObject first, LispObject second)
0425: throws ConditionThrowable {
0426: return first.CONSTANTP();
0427: }
0428: };
0429:
0430: // ### functionp
0431: private static final Primitive1 FUNCTIONP = new Primitive1(
0432: "functionp") {
0433: public LispObject execute(LispObject arg)
0434: throws ConditionThrowable {
0435: return (arg instanceof Function || arg instanceof GenericFunction) ? T
0436: : NIL;
0437: }
0438: };
0439:
0440: // ### symbolp
0441: private static final Primitive1 SYMBOLP = new Primitive1("symbolp") {
0442: public LispObject execute(LispObject arg)
0443: throws ConditionThrowable {
0444: return arg.SYMBOLP();
0445: }
0446: };
0447:
0448: // ### endp
0449: private static final Primitive1 ENDP = new Primitive1("endp") {
0450: public LispObject execute(LispObject arg)
0451: throws ConditionThrowable {
0452: return arg.ENDP();
0453: }
0454: };
0455:
0456: // ### null
0457: private static final Primitive1 NULL = new Primitive1("null") {
0458: public LispObject execute(LispObject arg)
0459: throws ConditionThrowable {
0460: return arg == NIL ? T : NIL;
0461: }
0462: };
0463:
0464: // ### not
0465: private static final Primitive1 NOT = new Primitive1("not") {
0466: public LispObject execute(LispObject arg)
0467: throws ConditionThrowable {
0468: return arg == NIL ? T : NIL;
0469: }
0470: };
0471:
0472: // ### plusp
0473: private static final Primitive1 PLUSP = new Primitive1("plusp") {
0474: public LispObject execute(LispObject arg)
0475: throws ConditionThrowable {
0476: return arg.PLUSP();
0477: }
0478: };
0479:
0480: // ### minusp
0481: private static final Primitive1 MINUSP = new Primitive1("minusp") {
0482: public LispObject execute(LispObject arg)
0483: throws ConditionThrowable {
0484: return arg.MINUSP();
0485: }
0486: };
0487:
0488: // ### zerop
0489: private static final Primitive1 ZEROP = new Primitive1("zerop") {
0490: public LispObject execute(LispObject arg)
0491: throws ConditionThrowable {
0492: return arg.ZEROP();
0493: }
0494: };
0495:
0496: // ### fixnump
0497: private static final Primitive1 FIXNUMP = new Primitive1("fixnump",
0498: PACKAGE_EXT, true) {
0499: public LispObject execute(LispObject arg)
0500: throws ConditionThrowable {
0501: return arg instanceof Fixnum ? T : NIL;
0502: }
0503: };
0504:
0505: // ### symbol-value
0506: private static final Primitive1 SYMBOL_VALUE = new Primitive1(
0507: "symbol-value") {
0508: public LispObject execute(LispObject arg)
0509: throws ConditionThrowable {
0510: if (arg == T)
0511: return T;
0512: if (arg == NIL)
0513: return NIL;
0514: LispObject value = checkSymbol(arg).symbolValue();
0515: if (value instanceof SymbolMacro)
0516: throw new ConditionThrowable(new LispError(arg
0517: + " has no dynamic value"));
0518: return value;
0519: }
0520: };
0521:
0522: // ### +
0523: private static final Primitive ADD = new Primitive("+") {
0524: public LispObject execute(LispObject first, LispObject second)
0525: throws ConditionThrowable {
0526: return first.add(second);
0527: }
0528:
0529: public LispObject execute(LispObject[] args)
0530: throws ConditionThrowable {
0531: LispObject result = Fixnum.ZERO;
0532: final int length = args.length;
0533: for (int i = 0; i < length; i++)
0534: result = result.add(args[i]);
0535: return result;
0536: }
0537: };
0538:
0539: // ### -
0540: private static final Primitive SUBTRACT = new Primitive("-") {
0541: public LispObject execute(LispObject first, LispObject second)
0542: throws ConditionThrowable {
0543: return first.subtract(second);
0544: }
0545:
0546: public LispObject execute(LispObject[] args)
0547: throws ConditionThrowable {
0548: switch (args.length) {
0549: case 0:
0550: throw new ConditionThrowable(
0551: new WrongNumberOfArgumentsException("-"));
0552: case 1:
0553: return Fixnum.ZERO.subtract(args[0]);
0554: case 2:
0555: Debug.assertTrue(false);
0556: return args[0].subtract(args[1]);
0557: default: {
0558: LispObject result = args[0];
0559: for (int i = 1; i < args.length; i++)
0560: result = result.subtract(args[i]);
0561: return result;
0562: }
0563: }
0564: }
0565: };
0566:
0567: // ### when
0568: private static final SpecialOperator WHEN = new SpecialOperator(
0569: "when") {
0570: public LispObject execute(LispObject args, Environment env)
0571: throws ConditionThrowable {
0572: if (args == NIL)
0573: throw new ConditionThrowable(
0574: new WrongNumberOfArgumentsException(this ));
0575: final LispThread thread = LispThread.currentThread();
0576: LispObject result = NIL;
0577: if (eval(args.car(), env, thread) != NIL) {
0578: args = args.cdr();
0579: while (args != NIL) {
0580: result = eval(args.car(), env, thread);
0581: args = args.cdr();
0582: }
0583: }
0584: return result;
0585: }
0586: };
0587:
0588: // ### unless
0589: private static final SpecialOperator UNLESS = new SpecialOperator(
0590: "unless") {
0591: public LispObject execute(LispObject args, Environment env)
0592: throws ConditionThrowable {
0593: if (args == NIL)
0594: throw new ConditionThrowable(
0595: new WrongNumberOfArgumentsException(this ));
0596: final LispThread thread = LispThread.currentThread();
0597: LispObject result = NIL;
0598: if (eval(args.car(), env, thread) == NIL) {
0599: args = args.cdr();
0600: while (args != NIL) {
0601: result = eval(args.car(), env, thread);
0602: args = args.cdr();
0603: }
0604: }
0605: return result;
0606: }
0607: };
0608:
0609: // ### %write
0610: // %write object stream => object
0611: private static final Primitive2 _WRITE = new Primitive2("%write",
0612: PACKAGE_SYS, false) {
0613: public LispObject execute(LispObject first, LispObject second)
0614: throws ConditionThrowable {
0615: outSynonymOf(second).writeString(String.valueOf(first));
0616: return first;
0617: }
0618: };
0619:
0620: // ### princ
0621: // princ object &optional output-stream => object
0622: private static final Primitive PRINC = new Primitive("princ") {
0623: public LispObject execute(LispObject[] args)
0624: throws ConditionThrowable {
0625: if (args.length < 1 || args.length > 2)
0626: throw new ConditionThrowable(
0627: new WrongNumberOfArgumentsException(this ));
0628: final CharacterOutputStream out;
0629: if (args.length == 1)
0630: out = checkCharacterOutputStream(_STANDARD_OUTPUT_
0631: .symbolValue());
0632: else
0633: out = outSynonymOf(args[1]);
0634: out.princ(args[0]);
0635: return args[0];
0636: }
0637: };
0638:
0639: // ### princ-to-string
0640: private static final Primitive1 PRINC_TO_STRING = new Primitive1(
0641: "princ-to-string") {
0642: public LispObject execute(LispObject arg)
0643: throws ConditionThrowable {
0644: LispThread thread = LispThread.currentThread();
0645: Environment oldDynEnv = thread.getDynamicEnvironment();
0646: thread.bindSpecial(_PRINT_ESCAPE_, NIL);
0647: LispString string = new LispString(String.valueOf(arg));
0648: thread.setDynamicEnvironment(oldDynEnv);
0649: return string;
0650: }
0651: };
0652:
0653: // ### prin1
0654: // prin1 object &optional output-stream => object
0655: private static final Primitive PRIN1 = new Primitive("prin1") {
0656: public LispObject execute(LispObject arg)
0657: throws ConditionThrowable {
0658: CharacterOutputStream out = checkCharacterOutputStream(_STANDARD_OUTPUT_
0659: .symbolValue());
0660: out.prin1(arg);
0661: return arg;
0662: }
0663:
0664: public LispObject execute(LispObject first, LispObject second)
0665: throws ConditionThrowable {
0666: outSynonymOf(second).prin1(first);
0667: return first;
0668: }
0669: };
0670:
0671: // ### prin1-to-string
0672: private static final Primitive1 PRIN1_TO_STRING = new Primitive1(
0673: "prin1-to-string") {
0674: public LispObject execute(LispObject arg)
0675: throws ConditionThrowable {
0676: return new LispString(String.valueOf(arg));
0677: }
0678: };
0679:
0680: // ### print
0681: // print object &optional output-stream => object
0682: // PRINT is just like PRIN1 except that the printed representation of
0683: // object is preceded by a newline and followed by a space.
0684: private static final Primitive1 PRINT = new Primitive1("print") {
0685: public LispObject execute(LispObject arg)
0686: throws ConditionThrowable {
0687: CharacterOutputStream out = checkCharacterOutputStream(_STANDARD_OUTPUT_
0688: .symbolValue());
0689: out.terpri();
0690: out.prin1(arg);
0691: out.writeString(" ");
0692: return arg;
0693: }
0694:
0695: public LispObject execute(LispObject first, LispObject second)
0696: throws ConditionThrowable {
0697: CharacterOutputStream out = outSynonymOf(second);
0698: out.terpri();
0699: out.prin1(first);
0700: out.writeString(" ");
0701: return first;
0702: }
0703: };
0704:
0705: // ### terpri
0706: // terpri &optional output-stream => nil
0707: private static final Primitive TERPRI = new Primitive("terpri") {
0708: public LispObject execute(LispObject[] args)
0709: throws ConditionThrowable {
0710: if (args.length > 1)
0711: throw new ConditionThrowable(
0712: new WrongNumberOfArgumentsException(this ));
0713: final CharacterOutputStream out;
0714: if (args.length == 0)
0715: out = checkCharacterOutputStream(_STANDARD_OUTPUT_
0716: .symbolValue());
0717: else
0718: out = outSynonymOf(args[0]);
0719: return out.terpri();
0720: }
0721: };
0722:
0723: // ### fresh-line
0724: // fresh-line &optional output-stream => generalized-boolean
0725: private static final Primitive FRESH_LINE = new Primitive(
0726: "fresh-line") {
0727: public LispObject execute(LispObject[] args)
0728: throws ConditionThrowable {
0729: if (args.length > 1)
0730: throw new ConditionThrowable(
0731: new WrongNumberOfArgumentsException(this ));
0732: CharacterOutputStream out;
0733: if (args.length == 0)
0734: out = checkCharacterOutputStream(_STANDARD_OUTPUT_
0735: .symbolValue());
0736: else
0737: out = outSynonymOf(args[0]);
0738: return out.freshLine();
0739: }
0740: };
0741:
0742: // ### boundp
0743: private static final Primitive1 BOUNDP = new Primitive1("boundp") {
0744: public LispObject execute(LispObject obj)
0745: throws ConditionThrowable {
0746: if (obj == NIL)
0747: return T;
0748: Symbol symbol = checkSymbol(obj);
0749: if (LispThread.currentThread().lookupSpecial(symbol) != null)
0750: return T;
0751: return symbol.getSymbolValue() != null ? T : NIL;
0752: }
0753: };
0754:
0755: // ### fboundp
0756: private static final Primitive1 FBOUNDP = new Primitive1("fboundp") {
0757: public LispObject execute(LispObject arg)
0758: throws ConditionThrowable {
0759: if (arg instanceof Symbol)
0760: return arg.getSymbolFunction() != null ? T : NIL;
0761: if (arg instanceof Cons && arg.car() == Symbol.SETF) {
0762: LispObject f = get(checkSymbol(arg.cadr()), PACKAGE_SYS
0763: .intern("SETF-FUNCTION"));
0764: return f != null ? T : NIL;
0765: }
0766: throw new ConditionThrowable(new TypeError(arg,
0767: "valid function name"));
0768: }
0769: };
0770:
0771: // ### fmakunbound
0772: private static final Primitive1 FMAKUNBOUND = new Primitive1(
0773: "fmakunbound") {
0774: public LispObject execute(LispObject arg)
0775: throws ConditionThrowable {
0776: if (arg instanceof Symbol) {
0777: ((Symbol) arg).setSymbolFunction(null);
0778: } else if (arg instanceof Cons && arg.car() == Symbol.SETF) {
0779: remprop(checkSymbol(arg.cadr()), PACKAGE_SYS
0780: .intern("SETF-FUNCTION"));
0781: } else
0782: throw new ConditionThrowable(new TypeError(arg,
0783: "valid function name"));
0784: return arg;
0785: }
0786: };
0787:
0788: // ### remprop
0789: private static final Primitive2 REMPROP = new Primitive2("remprop") {
0790: public LispObject execute(LispObject first, LispObject second)
0791: throws ConditionThrowable {
0792: return remprop(checkSymbol(first), second);
0793: }
0794: };
0795:
0796: // ### append
0797: public static final Primitive APPEND = new Primitive("append") {
0798: public LispObject execute() {
0799: return NIL;
0800: }
0801:
0802: public LispObject execute(LispObject arg) {
0803: return arg;
0804: }
0805:
0806: public LispObject execute(LispObject first, LispObject second)
0807: throws ConditionThrowable {
0808: if (first == NIL)
0809: return second;
0810: // APPEND is required to copy its first argument.
0811: Cons result = new Cons(first.car());
0812: Cons splice = result;
0813: first = first.cdr();
0814: while (first != NIL) {
0815: Cons temp = new Cons(first.car());
0816: splice.setCdr(temp);
0817: splice = temp;
0818: first = first.cdr();
0819: }
0820: splice.setCdr(second);
0821: return result;
0822: }
0823:
0824: public LispObject execute(LispObject[] args)
0825: throws ConditionThrowable {
0826: Cons result = null;
0827: Cons splice = null;
0828: final int limit = args.length - 1;
0829: int i;
0830: for (i = 0; i < limit; i++) {
0831: LispObject top = args[i];
0832: if (top == NIL)
0833: continue;
0834: result = new Cons(top.car());
0835: splice = result;
0836: top = top.cdr();
0837: while (top != NIL) {
0838: Cons temp = new Cons(top.car());
0839: splice.setCdr(temp);
0840: splice = temp;
0841: top = top.cdr();
0842: }
0843: break;
0844: }
0845: if (result == null)
0846: return args[i];
0847: for (++i; i < limit; i++) {
0848: LispObject top = args[i];
0849: while (top != NIL) {
0850: Cons temp = new Cons(top.car());
0851: splice.setCdr(temp);
0852: splice = temp;
0853: top = top.cdr();
0854: }
0855: }
0856: splice.setCdr(args[i]);
0857: return result;
0858: }
0859: };
0860:
0861: // ### nconc
0862: private static final Primitive NCONC = new Primitive("nconc") {
0863: public LispObject execute(LispObject[] array)
0864: throws ConditionThrowable {
0865: switch (array.length) {
0866: case 0:
0867: return NIL;
0868: case 1:
0869: return array[0];
0870: default: {
0871: LispObject result = null;
0872: LispObject splice = null;
0873: final int limit = array.length - 1;
0874: int i;
0875: for (i = 0; i < limit; i++) {
0876: LispObject list = array[i];
0877: if (list == NIL)
0878: continue;
0879: if (list instanceof Cons) {
0880: if (splice != null) {
0881: splice.setCdr(list);
0882: splice = list;
0883: }
0884: while (list instanceof Cons) {
0885: if (result == null) {
0886: result = list;
0887: splice = result;
0888: } else {
0889: splice = list;
0890: }
0891: list = list.cdr();
0892: }
0893: } else
0894: throw new ConditionThrowable(new TypeError(
0895: list, "list"));
0896: }
0897: if (result == null)
0898: return array[i];
0899: splice.setCdr(array[i]);
0900: return result;
0901: }
0902: }
0903: }
0904: };
0905:
0906: // ### =
0907: // Numeric equality.
0908: private static final Primitive EQUALS = new Primitive("=") {
0909: public LispObject execute(LispObject first, LispObject second)
0910: throws ConditionThrowable {
0911: return first.isEqualTo(second) ? T : NIL;
0912: }
0913:
0914: public LispObject execute(LispObject[] array)
0915: throws ConditionThrowable {
0916: final int length = array.length;
0917: if (length < 1)
0918: throw new ConditionThrowable(
0919: new WrongNumberOfArgumentsException(this ));
0920: final LispObject obj = array[0];
0921: for (int i = 1; i < length; i++) {
0922: if (array[i].isNotEqualTo(obj))
0923: return NIL;
0924: }
0925: return T;
0926: }
0927: };
0928:
0929: // Returns true if no two numbers are the same; otherwise returns false.
0930: private static final Primitive NOT_EQUALS = new Primitive("/=") {
0931: public LispObject execute(LispObject first, LispObject second)
0932: throws ConditionThrowable {
0933: return first.isNotEqualTo(second) ? T : NIL;
0934: }
0935:
0936: public LispObject execute(LispObject[] array)
0937: throws ConditionThrowable {
0938: final int length = array.length;
0939: if (length == 2)
0940: return array[0].isNotEqualTo(array[1]) ? T : NIL;
0941: if (length < 1)
0942: throw new ConditionThrowable(
0943: new WrongNumberOfArgumentsException(this ));
0944: for (int i = 0; i < length; i++) {
0945: final LispObject obj = array[i];
0946: for (int j = i + 1; j < length; j++) {
0947: if (array[j].isEqualTo(obj))
0948: return NIL;
0949: }
0950: }
0951: return T;
0952: }
0953: };
0954:
0955: // ### <
0956: // Numeric comparison.
0957: private static final Primitive LESS_THAN = new Primitive("<") {
0958: public LispObject execute(LispObject first, LispObject second)
0959: throws ConditionThrowable {
0960: return first.isLessThan(second) ? T : NIL;
0961: }
0962:
0963: public LispObject execute(LispObject[] array)
0964: throws ConditionThrowable {
0965: final int length = array.length;
0966: if (length < 1)
0967: throw new ConditionThrowable(
0968: new WrongNumberOfArgumentsException(this ));
0969: for (int i = 1; i < length; i++) {
0970: if (array[i].isLessThanOrEqualTo(array[i - 1]))
0971: return NIL;
0972: }
0973: return T;
0974: }
0975: };
0976:
0977: // ### <=
0978: private static final Primitive LE = new Primitive("<=") {
0979: public LispObject execute(LispObject first, LispObject second)
0980: throws ConditionThrowable {
0981: return first.isLessThanOrEqualTo(second) ? T : NIL;
0982: }
0983:
0984: public LispObject execute(LispObject[] array)
0985: throws ConditionThrowable {
0986: switch (array.length) {
0987: case 0:
0988: throw new ConditionThrowable(
0989: new WrongNumberOfArgumentsException(this ));
0990: case 1:
0991: return T;
0992: case 2:
0993: Debug.assertTrue(false);
0994: return array[0].isLessThanOrEqualTo(array[1]) ? T : NIL;
0995: default: {
0996: final int length = array.length;
0997: for (int i = 1; i < length; i++) {
0998: if (array[i].isLessThan(array[i - 1]))
0999: return NIL;
1000: }
1001: return T;
1002: }
1003: }
1004: }
1005: };
1006:
1007: // ### >
1008: private static final Primitive GREATER_THAN = new Primitive(">") {
1009: public LispObject execute(LispObject first, LispObject second)
1010: throws ConditionThrowable {
1011: return first.isGreaterThan(second) ? T : NIL;
1012: }
1013:
1014: public LispObject execute(LispObject[] array)
1015: throws ConditionThrowable {
1016: final int length = array.length;
1017: if (length < 1)
1018: throw new ConditionThrowable(
1019: new WrongNumberOfArgumentsException(this ));
1020: for (int i = 1; i < length; i++) {
1021: if (array[i].isGreaterThanOrEqualTo(array[i - 1]))
1022: return NIL;
1023: }
1024: return T;
1025: }
1026: };
1027:
1028: // ### >=
1029: private static final Primitive GE = new Primitive(">=") {
1030: public LispObject execute(LispObject first, LispObject second)
1031: throws ConditionThrowable {
1032: return first.isGreaterThanOrEqualTo(second) ? T : NIL;
1033: }
1034:
1035: public LispObject execute(LispObject[] array)
1036: throws ConditionThrowable {
1037: final int length = array.length;
1038: switch (length) {
1039: case 0:
1040: throw new ConditionThrowable(
1041: new WrongNumberOfArgumentsException(this ));
1042: case 1:
1043: return T;
1044: case 2:
1045: Debug.assertTrue(false);
1046: return array[0].isGreaterThanOrEqualTo(array[1]) ? T
1047: : NIL;
1048: default:
1049: for (int i = 1; i < length; i++) {
1050: if (array[i].isGreaterThan(array[i - 1]))
1051: return NIL;
1052: }
1053: return T;
1054: }
1055: }
1056: };
1057:
1058: // ### assoc
1059: // assoc item alist &key key test test-not => entry
1060: // This is the bootstrap version (needed for %set-documentation).
1061: // Redefined properly in assoc.lisp.
1062: private static final Primitive ASSOC = new Primitive("assoc") {
1063: public LispObject execute(LispObject[] args)
1064: throws ConditionThrowable {
1065: if (args.length != 2)
1066: throw new ConditionThrowable(
1067: new WrongNumberOfArgumentsException(this ));
1068: LispObject item = args[0];
1069: LispObject alist = args[1];
1070: while (alist != NIL) {
1071: LispObject cons = alist.car();
1072: if (cons instanceof Cons) {
1073: if (cons.car().eql(item))
1074: return cons;
1075: } else if (cons != NIL)
1076: throw new ConditionThrowable(new TypeError(cons,
1077: "list"));
1078: alist = alist.cdr();
1079: }
1080: return NIL;
1081: }
1082: };
1083:
1084: // ### nth
1085: // nth n list => object
1086: private static final Primitive2 NTH = new Primitive2("nth") {
1087: public LispObject execute(LispObject first, LispObject second)
1088: throws ConditionThrowable {
1089: int index = Fixnum.getValue(first);
1090: if (index < 0)
1091: throw new ConditionThrowable(new LispError(
1092: "bad index to NTH: " + index));
1093: int i = 0;
1094: while (true) {
1095: if (i == index)
1096: return second.car();
1097: second = second.cdr();
1098: if (second == NIL)
1099: return NIL;
1100: ++i;
1101: }
1102: }
1103: };
1104:
1105: // ### %set-nth
1106: // %setnth n list new-object => new-object
1107: private static final Primitive3 _SET_NTH = new Primitive3(
1108: "%set-nth", PACKAGE_SYS, false) {
1109: public LispObject execute(LispObject first, LispObject second,
1110: LispObject third) throws ConditionThrowable {
1111: int index = Fixnum.getValue(first);
1112: if (index < 0)
1113: throw new ConditionThrowable(new LispError(
1114: "bad index to NTH: " + index));
1115: int i = 0;
1116: while (true) {
1117: if (i == index) {
1118: second.setCar(third);
1119: return third;
1120: }
1121: second = second.cdr();
1122: if (second == NIL)
1123: throw new ConditionThrowable(new LispError(String
1124: .valueOf(index))
1125: + "is too large an index for SETF of NTH");
1126: ++i;
1127: }
1128: }
1129: };
1130:
1131: // ### nthcdr
1132: private static final Primitive2 NTHCDR = new Primitive2("nthcdr") {
1133: public LispObject execute(LispObject first, LispObject second)
1134: throws ConditionThrowable {
1135: final int index = Fixnum.getValue(first);
1136: if (index < 0)
1137: throw new ConditionThrowable(new TypeError(
1138: "bad index to NTHCDR: " + index));
1139: for (int i = 0; i < index; i++) {
1140: second = second.cdr();
1141: if (second == NIL)
1142: return NIL;
1143: }
1144: return second;
1145: }
1146: };
1147:
1148: // ### error
1149: private static final Primitive ERROR = new Primitive("error") {
1150: public LispObject execute(LispObject[] args)
1151: throws ConditionThrowable {
1152: if (args.length < 1)
1153: throw new ConditionThrowable(
1154: new WrongNumberOfArgumentsException(this ));
1155: LispObject datum = args[0];
1156: if (datum instanceof LispError)
1157: throw new ConditionThrowable((LispError) datum);
1158: if (datum instanceof Symbol) {
1159: if (datum == Symbol.PACKAGE_ERROR)
1160: throw new ConditionThrowable(new PackageError(
1161: _format(args, 1)));
1162: if (datum == Symbol.PARSE_ERROR)
1163: throw new ConditionThrowable(new ParseError(
1164: _format(args, 1)));
1165: if (datum == Symbol.PROGRAM_ERROR)
1166: throw new ConditionThrowable(new ProgramError(
1167: _format(args, 1)));
1168: if (datum == Symbol.SIMPLE_ERROR)
1169: throw new ConditionThrowable(new SimpleError(
1170: _format(args, 1)));
1171: if (datum == Symbol.TYPE_ERROR)
1172: throw new ConditionThrowable(new TypeError(_format(
1173: args, 1)));
1174: // Default.
1175: throw new ConditionThrowable(new SimpleError(
1176: ((Symbol) datum).getName()));
1177: }
1178: throw new ConditionThrowable(new SimpleError(_format(args)));
1179: }
1180: };
1181:
1182: // ### signal
1183: private static final Primitive SIGNAL = new Primitive("signal") {
1184: public LispObject execute(LispObject[] args)
1185: throws ConditionThrowable {
1186: if (args.length < 1)
1187: throw new ConditionThrowable(
1188: new WrongNumberOfArgumentsException(this ));
1189: if (args[0] instanceof Condition)
1190: throw new ConditionThrowable((Condition) args[0]);
1191: throw new ConditionThrowable(new SimpleCondition());
1192: }
1193: };
1194:
1195: // ### format
1196: private static final Primitive FORMAT = new Primitive("format") {
1197: public LispObject execute(LispObject[] args)
1198: throws ConditionThrowable {
1199: if (args.length < 2)
1200: throw new ConditionThrowable(
1201: new WrongNumberOfArgumentsException(this ));
1202: LispObject destination = args[0];
1203: // Copy remaining arguments.
1204: LispObject[] _args = new LispObject[args.length - 1];
1205: for (int i = 0; i < _args.length; i++)
1206: _args[i] = args[i + 1];
1207: String s = _format(_args);
1208: if (destination == T) {
1209: checkCharacterOutputStream(
1210: _STANDARD_OUTPUT_.symbolValue()).writeString(s);
1211: return NIL;
1212: }
1213: if (destination == NIL)
1214: return new LispString(s);
1215: if (destination instanceof CharacterOutputStream) {
1216: ((CharacterOutputStream) destination).writeString(s);
1217: return NIL;
1218: }
1219: if (destination instanceof TwoWayStream) {
1220: LispOutputStream out = ((TwoWayStream) destination)
1221: .getOutputStream();
1222: if (out instanceof CharacterOutputStream) {
1223: ((CharacterOutputStream) out).writeString(s);
1224: return NIL;
1225: }
1226: throw new ConditionThrowable(new TypeError(destination,
1227: "character output stream"));
1228: }
1229: // Destination can also be a string with a fill pointer.
1230: // throw new ConditionThrowable(new LispError("FORMAT: not implemented"));
1231: return NIL;
1232: }
1233: };
1234:
1235: private static final String _format(LispObject[] args, int skip)
1236: throws ConditionThrowable {
1237: final int remaining = args.length - skip;
1238: if (remaining > 0) {
1239: LispObject[] array = new LispObject[remaining];
1240: for (int i = skip, j = 0; i < args.length; i++, j++)
1241: array[j] = args[i];
1242: return _format(array);
1243: } else
1244: return null;
1245: }
1246:
1247: private static final String _format(LispObject[] args)
1248: throws ConditionThrowable {
1249: final LispThread thread = LispThread.currentThread();
1250: String control = checkString(args[0]).getValue();
1251: StringBuffer sb = new StringBuffer();
1252: final int limit = control.length();
1253: int j = 1;
1254: final int NEUTRAL = 0;
1255: final int TILDE = 1;
1256: int state = NEUTRAL;
1257: for (int i = 0; i < limit; i++) {
1258: char c = control.charAt(i);
1259: if (state == NEUTRAL) {
1260: if (c == '~')
1261: state = TILDE;
1262: else
1263: sb.append(c);
1264: } else if (state == TILDE) {
1265: if (c == 'A' || c == 'a') {
1266: if (j < args.length) {
1267: LispObject obj = args[j++];
1268: Environment oldDynEnv = thread
1269: .getDynamicEnvironment();
1270: thread.bindSpecial(_PRINT_ESCAPE_, NIL);
1271: sb.append(String.valueOf(obj));
1272: thread.setDynamicEnvironment(oldDynEnv);
1273: }
1274: } else if (c == 'S' || c == 's') {
1275: if (j < args.length) {
1276: LispObject obj = args[j++];
1277: Environment oldDynEnv = thread
1278: .getDynamicEnvironment();
1279: thread.bindSpecial(_PRINT_ESCAPE_, T);
1280: sb.append(String.valueOf(obj));
1281: thread.setDynamicEnvironment(oldDynEnv);
1282: }
1283: } else if (c == 'D' || c == 'd') {
1284: if (j < args.length) {
1285: LispObject obj = args[j++];
1286: Environment oldDynEnv = thread
1287: .getDynamicEnvironment();
1288: thread.bindSpecial(_PRINT_ESCAPE_, NIL);
1289: thread.bindSpecial(_PRINT_RADIX_, NIL);
1290: thread
1291: .bindSpecial(_PRINT_BASE_, new Fixnum(
1292: 10));
1293: sb.append(String.valueOf(obj));
1294: thread.setDynamicEnvironment(oldDynEnv);
1295: }
1296: } else if (c == 'X' || c == 'x') {
1297: if (j < args.length) {
1298: LispObject obj = args[j++];
1299: Environment oldDynEnv = thread
1300: .getDynamicEnvironment();
1301: thread.bindSpecial(_PRINT_ESCAPE_, NIL);
1302: thread.bindSpecial(_PRINT_RADIX_, NIL);
1303: thread
1304: .bindSpecial(_PRINT_BASE_, new Fixnum(
1305: 16));
1306: sb.append(String.valueOf(obj));
1307: thread.setDynamicEnvironment(oldDynEnv);
1308: }
1309: } else if (c == '%') {
1310: sb.append(System.getProperty("line.separator"));
1311: }
1312: // else
1313: // throw new ConditionThrowable(new LispError("FORMAT: not implemented"));
1314: state = NEUTRAL;
1315: } else {
1316: // There are no other valid states.
1317: Debug.assertTrue(false);
1318: }
1319: }
1320: return sb.toString();
1321: }
1322:
1323: // ### %defun
1324: // %defun name arglist body environment => name
1325: private static final Primitive _DEFUN = new Primitive("%defun",
1326: PACKAGE_SYS, false) {
1327: public LispObject execute(LispObject[] args)
1328: throws ConditionThrowable {
1329: if (args.length < 3 || args.length > 4)
1330: throw new ConditionThrowable(
1331: new WrongNumberOfArgumentsException(this ));
1332: LispObject first = args[0];
1333: LispObject second = args[1];
1334: LispObject third = args[2];
1335: Environment env;
1336: if (args.length == 4 && args[3] != NIL)
1337: env = checkEnvironment(args[3]);
1338: else
1339: env = new Environment();
1340: if (first instanceof Symbol) {
1341: Symbol symbol = checkSymbol(first);
1342: if (symbol.getSymbolFunction() instanceof SpecialOperator) {
1343: String message = symbol.getName()
1344: + " is a special operator and may not be redefined";
1345: throw new ConditionThrowable(new ProgramError(
1346: message));
1347: }
1348: LispObject arglist = checkList(second);
1349: LispObject body = checkList(third);
1350: if (body.car() instanceof LispString
1351: && body.cdr() != NIL) {
1352: // Documentation.
1353: symbol.setFunctionDocumentation(body.car());
1354: body = body.cdr();
1355: }
1356: LispObject decls = NIL;
1357: while (body.car() instanceof Cons
1358: && body.car().car() == Symbol.DECLARE) {
1359: decls = new Cons(body.car(), decls);
1360: body = body.cdr();
1361: }
1362: body = new Cons(symbol, body);
1363: body = new Cons(Symbol.BLOCK, body);
1364: body = new Cons(body, NIL);
1365: while (decls != NIL) {
1366: body = new Cons(decls.car(), body);
1367: decls = decls.cdr();
1368: }
1369: Closure closure = new Closure(symbol.getName(),
1370: arglist, body, env);
1371: closure.setArglist(arglist);
1372: symbol.setSymbolFunction(closure);
1373: return symbol;
1374: }
1375: if (first instanceof Cons && first.car() == Symbol.SETF) {
1376: Symbol symbol = checkSymbol(first.cadr());
1377: LispObject arglist = checkList(second);
1378: LispObject body = checkList(third);
1379: if (body.car() instanceof LispString
1380: && body.cdr() != NIL) {
1381: // Documentation.
1382: // symbol.setFunctionDocumentation(body.car());
1383: body = body.cdr();
1384: }
1385: body = new Cons(symbol, body);
1386: body = new Cons(Symbol.BLOCK, body);
1387: body = new Cons(body, NIL);
1388: Closure closure = new Closure(arglist, body, env);
1389: closure.setArglist(arglist);
1390: put(symbol, PACKAGE_SYS.intern("SETF-FUNCTION"),
1391: closure);
1392: return symbol;
1393: }
1394: throw new ConditionThrowable(new TypeError(first,
1395: "valid function name"));
1396: }
1397: };
1398:
1399: // ### macro-function
1400: // Need to support optional second argument specifying environment.
1401: private static final Primitive MACRO_FUNCTION = new Primitive(
1402: "macro-function") {
1403: public LispObject execute(LispObject[] args)
1404: throws ConditionThrowable {
1405: if (args.length != 1)
1406: throw new ConditionThrowable(
1407: new WrongNumberOfArgumentsException(this ));
1408: Symbol symbol = checkSymbol(args[0]);
1409: LispObject obj = symbol.getSymbolFunction();
1410: if (obj instanceof MacroObject)
1411: return ((MacroObject) obj).getExpander();
1412: if (obj instanceof SpecialOperator) {
1413: LispObject macroObject = get(symbol,
1414: Symbol.MACROEXPAND_MACRO, NIL);
1415: if (macroObject instanceof MacroObject)
1416: return ((MacroObject) macroObject).getExpander();
1417: return NIL;
1418: }
1419: if (obj instanceof AutoloadMacro)
1420: return obj;
1421:
1422: return NIL;
1423: }
1424: };
1425:
1426: // ### defmacro
1427: private static final SpecialOperator DEFMACRO = new SpecialOperator(
1428: "defmacro") {
1429: public LispObject execute(LispObject args, Environment env)
1430: throws ConditionThrowable {
1431: Symbol symbol = checkSymbol(args.car());
1432: LispObject lambdaList = checkList(args.cadr());
1433: LispObject body = args.cddr();
1434: LispObject block = new Cons(Symbol.BLOCK, new Cons(symbol,
1435: body));
1436: LispObject toBeApplied = list2(Symbol.FUNCTION, list3(
1437: Symbol.LAMBDA, lambdaList, block));
1438: LispObject formArg = gensym("FORM-");
1439: LispObject envArg = gensym("ENV-"); // Ignored.
1440: LispObject expander = list3(Symbol.LAMBDA, list2(formArg,
1441: envArg), list3(Symbol.APPLY, toBeApplied, list2(
1442: Symbol.CDR, formArg)));
1443: Closure expansionFunction = new Closure(expander.cadr(),
1444: expander.cddr(), env);
1445: MacroObject macroObject = new MacroObject(expansionFunction);
1446: if (symbol.getSymbolFunction() instanceof SpecialOperator)
1447: put(symbol, Symbol.MACROEXPAND_MACRO, macroObject);
1448: else
1449: symbol.setSymbolFunction(macroObject);
1450: LispThread.currentThread().clearValues();
1451: return symbol;
1452: }
1453: };
1454:
1455: // ### make-macro
1456: private static final Primitive1 MAKE_MACRO = new Primitive1(
1457: "make-macro", PACKAGE_SYS, false) {
1458: public LispObject execute(LispObject arg)
1459: throws ConditionThrowable {
1460: return new MacroObject(arg);
1461: }
1462: };
1463:
1464: // ### %defparameter
1465: private static final Primitive3 _DEFPARAMETER = new Primitive3(
1466: "%defparameter", PACKAGE_SYS, false) {
1467: public LispObject execute(LispObject first, LispObject second,
1468: LispObject third) throws ConditionThrowable {
1469: Symbol symbol = checkSymbol(first);
1470: if (third instanceof LispString)
1471: symbol.setVariableDocumentation(third);
1472: else if (third != NIL)
1473: throw new ConditionThrowable(new TypeError(third,
1474: "string"));
1475: symbol.setSymbolValue(second);
1476: symbol.setSpecial(true);
1477: return symbol;
1478: }
1479: };
1480:
1481: // ### %defvar
1482: private static final Primitive1 _DEFVAR = new Primitive1("%defvar",
1483: PACKAGE_SYS, false) {
1484: public LispObject execute(LispObject arg)
1485: throws ConditionThrowable {
1486: Symbol symbol = checkSymbol(arg);
1487: symbol.setSpecial(true);
1488: return symbol;
1489: }
1490: };
1491:
1492: // ### %defconstant
1493: private static final Primitive3 _DEFCONSTANT = new Primitive3(
1494: "%defconstant", PACKAGE_SYS, false) {
1495: public LispObject execute(LispObject first, LispObject second,
1496: LispObject third) throws ConditionThrowable {
1497: Symbol symbol = checkSymbol(first);
1498: if (third instanceof LispString)
1499: symbol.setVariableDocumentation(third);
1500: else if (third != NIL)
1501: throw new ConditionThrowable(new TypeError(third,
1502: "string"));
1503: symbol.setSymbolValue(second);
1504: symbol.setSpecial(true);
1505: symbol.setConstant(true);
1506: return symbol;
1507: }
1508: };
1509:
1510: // ### cond
1511: private static final SpecialOperator COND = new SpecialOperator(
1512: "cond") {
1513: public LispObject execute(LispObject args, Environment env)
1514: throws ConditionThrowable {
1515: final LispThread thread = LispThread.currentThread();
1516: LispObject result = NIL;
1517: while (args != NIL) {
1518: LispObject clause = args.car();
1519: result = eval(clause.car(), env, thread);
1520: thread.clearValues();
1521: if (result != NIL) {
1522: LispObject body = clause.cdr();
1523: while (body != NIL) {
1524: result = eval(body.car(), env, thread);
1525: body = body.cdr();
1526: }
1527: return result;
1528: }
1529: args = args.cdr();
1530: }
1531: return result;
1532: }
1533: };
1534:
1535: // ### case
1536: private static final SpecialOperator CASE = new SpecialOperator(
1537: "case") {
1538: public LispObject execute(LispObject args, Environment env)
1539: throws ConditionThrowable {
1540: final LispThread thread = LispThread.currentThread();
1541: LispObject key = eval(args.car(), env, thread);
1542: args = args.cdr();
1543: while (args != NIL) {
1544: LispObject clause = args.car();
1545: LispObject keys = clause.car();
1546: boolean match = false;
1547: if (keys.listp()) {
1548: while (keys != NIL) {
1549: LispObject candidate = keys.car();
1550: if (key.eql(candidate)) {
1551: match = true;
1552: break;
1553: }
1554: keys = keys.cdr();
1555: }
1556: } else {
1557: LispObject candidate = keys;
1558: if (candidate == T || candidate == Symbol.OTHERWISE)
1559: match = true;
1560: else if (key.eql(candidate))
1561: match = true;
1562: }
1563: if (match) {
1564: return progn(clause.cdr(), env, thread);
1565: }
1566: args = args.cdr();
1567: }
1568: return NIL;
1569: }
1570: };
1571:
1572: // ### ecase
1573: private static final SpecialOperator ECASE = new SpecialOperator(
1574: "ecase") {
1575: public LispObject execute(LispObject args, Environment env)
1576: throws ConditionThrowable {
1577: final LispThread thread = LispThread.currentThread();
1578: LispObject key = eval(args.car(), env, thread);
1579: args = args.cdr();
1580: while (args != NIL) {
1581: LispObject clause = args.car();
1582: LispObject keys = clause.car();
1583: boolean match = false;
1584: if (keys instanceof Cons) {
1585: while (keys != NIL) {
1586: LispObject candidate = keys.car();
1587: if (key.eql(candidate)) {
1588: match = true;
1589: break;
1590: }
1591: keys = keys.cdr();
1592: }
1593: } else {
1594: LispObject candidate = keys;
1595: if (key.eql(candidate))
1596: match = true;
1597: }
1598: if (match) {
1599: return progn(clause.cdr(), env, thread);
1600: }
1601: args = args.cdr();
1602: }
1603: throw new ConditionThrowable(new TypeError(
1604: "ECASE: no match for " + key));
1605: }
1606: };
1607:
1608: // ### handler-bind
1609: private static final SpecialOperator HANDLER_BIND = new SpecialOperator(
1610: "handler-bind") {
1611: public LispObject execute(LispObject args, Environment env)
1612: throws ConditionThrowable {
1613: LispObject bindings = checkList(args.car());
1614: final LispThread thread = LispThread.currentThread();
1615: LispObject forms = args.cdr();
1616: try {
1617: return progn(args.cdr(), env, thread);
1618: } catch (Return ret) {
1619: throw ret;
1620: } catch (ConditionThrowable throwable) {
1621: if (throwable instanceof Throw) {
1622: LispObject tag = ((Throw) throwable).getTag();
1623: if (thread.isValidCatchTag(tag))
1624: throw throwable;
1625: }
1626: Condition condition = throwable.getCondition();
1627: while (bindings != NIL) {
1628: Cons binding = checkCons(bindings.car());
1629: LispObject type = binding.car();
1630: if (condition.typep(type) != NIL) {
1631: LispObject obj = eval(binding.cadr(), env,
1632: thread);
1633: LispObject handler;
1634: if (obj instanceof Symbol) {
1635: handler = obj.getSymbolFunction();
1636: if (handler == null)
1637: throw new ConditionThrowable(
1638: new UndefinedFunction(obj));
1639: } else
1640: handler = obj;
1641: LispObject[] handlerArgs = new LispObject[1];
1642: handlerArgs[0] = condition;
1643: // Might not return.
1644: funcall(handler, handlerArgs, thread);
1645: }
1646: bindings = bindings.cdr();
1647: }
1648: // Re-throw.
1649: throw throwable;
1650: }
1651: }
1652: };
1653:
1654: // ### handler-case
1655: // Should be a macro.
1656: private static final SpecialOperator HANDLER_CASE = new SpecialOperator(
1657: "handler-case") {
1658: public LispObject execute(LispObject args, Environment env)
1659: throws ConditionThrowable {
1660: LispObject form = args.car();
1661: LispObject clauses = args.cdr();
1662: final LispThread thread = LispThread.currentThread();
1663: final int depth = thread.getStackDepth();
1664: LispObject result;
1665: try {
1666: result = eval(form, env, thread);
1667: } catch (Return ret) {
1668: throw ret;
1669: } catch (ConditionThrowable throwable) {
1670: if (throwable instanceof Throw) {
1671: LispObject tag = ((Throw) throwable).getTag();
1672: if (thread.isValidCatchTag(tag))
1673: throw throwable;
1674: }
1675: Condition condition = throwable.getCondition();
1676: thread.setStackDepth(depth);
1677: while (clauses != NIL) {
1678: Cons clause = checkCons(clauses.car());
1679: LispObject type = clause.car();
1680: if (condition.typep(type) != NIL) {
1681: LispObject parameterList = clause.cadr();
1682: LispObject body = clause.cdr().cdr();
1683: Closure handler = new Closure(parameterList,
1684: body, env);
1685: int numArgs = parameterList.length();
1686: if (numArgs == 1) {
1687: LispObject[] handlerArgs = new LispObject[1];
1688: handlerArgs[0] = condition;
1689: return funcall(handler, handlerArgs, thread);
1690: }
1691: if (numArgs == 0) {
1692: LispObject[] handlerArgs = new LispObject[0];
1693: return funcall(handler, handlerArgs, thread);
1694: }
1695: throw new ConditionThrowable(new LispError(
1696: "HANDLER-CASE: invalid handler clause"));
1697: }
1698: clauses = clauses.cdr();
1699: }
1700: // Re-throw.
1701: throw throwable;
1702: }
1703: // No error.
1704: while (clauses != NIL) {
1705: Cons clause = checkCons(clauses.car());
1706: if (clause.car() == Keyword.NO_ERROR) {
1707: Closure closure = new Closure(clause.cadr(), clause
1708: .cddr(), env);
1709: if (thread.getValues() != null)
1710: result = closure.execute(thread.getValues());
1711: else
1712: result = closure.execute(result);
1713: break;
1714: }
1715: clauses = clauses.cdr();
1716: }
1717: return result;
1718: }
1719: };
1720:
1721: // ### upgraded-array-element-type
1722: // upgraded-array-element-type typespec &optional environment
1723: // => upgraded-typespec
1724: private static final Primitive UPGRADED_ARRAY_ELEMENT_TYPE = new Primitive(
1725: "upgraded-array-element-type") {
1726: public LispObject execute(LispObject arg)
1727: throws ConditionThrowable {
1728: return getUpgradedArrayElementType(arg);
1729: }
1730:
1731: public LispObject execute(LispObject first, LispObject second)
1732: throws ConditionThrowable {
1733: // Ignore environment.
1734: return getUpgradedArrayElementType(first);
1735: }
1736: };
1737:
1738: // ### array-rank
1739: // array-rank array => rank
1740: private static final Primitive1 ARRAY_RANK = new Primitive1(
1741: "array-rank") {
1742: public LispObject execute(LispObject arg)
1743: throws ConditionThrowable {
1744: return new Fixnum(checkArray(arg).getRank());
1745: }
1746: };
1747:
1748: // ### array-dimensions
1749: // array-dimensions array => dimensions
1750: // Returns a list of integers. Fill pointer (if any) is ignored.
1751: private static final Primitive1 ARRAY_DIMENSIONS = new Primitive1(
1752: "array-dimensions") {
1753: public LispObject execute(LispObject arg)
1754: throws ConditionThrowable {
1755: return checkArray(arg).getDimensions();
1756: }
1757: };
1758:
1759: // ### array-dimension
1760: // array-dimension array axis-number => dimension
1761: private static final Primitive2 ARRAY_DIMENSION = new Primitive2(
1762: "array-dimension") {
1763: public LispObject execute(LispObject first, LispObject second)
1764: throws ConditionThrowable {
1765: return new Fixnum(checkArray(first).getDimension(
1766: Fixnum.getValue(second)));
1767: }
1768: };
1769:
1770: // ### array-total-size
1771: // array-total-size array => size
1772: private static final Primitive1 ARRAY_TOTAL_SIZE = new Primitive1(
1773: "array-total-size") {
1774: public LispObject execute(LispObject arg)
1775: throws ConditionThrowable {
1776: return new Fixnum(checkArray(arg).getTotalSize());
1777: }
1778: };
1779:
1780: // ### array-element-type
1781: // array-element-type array => typespec
1782: private static final Primitive1 ARRAY_ELEMENT_TYPE = new Primitive1(
1783: "array-element-type") {
1784: public LispObject execute(LispObject arg)
1785: throws ConditionThrowable {
1786: return checkArray(arg).getElementType();
1787: }
1788: };
1789:
1790: // ### array-in-bounds-p
1791: // array-in-bounds-p array &rest subscripts => generalized-boolean
1792: private static final Primitive ARRAY_IN_BOUNDS_P = new Primitive(
1793: "array-in-bounds-p") {
1794: public LispObject execute(LispObject[] args)
1795: throws ConditionThrowable {
1796: if (args.length < 1)
1797: throw new ConditionThrowable(
1798: new WrongNumberOfArgumentsException(this ));
1799: AbstractArray array = checkArray(args[0]);
1800: int rank = array.getRank();
1801: if (rank != args.length - 1) {
1802: StringBuffer sb = new StringBuffer(
1803: "ARRAY-IN-BOUNDS-P: ");
1804: sb.append("wrong number of subscripts (");
1805: sb.append(args.length - 1);
1806: sb.append(") for array of rank ");
1807: sb.append(rank);
1808: throw new ConditionThrowable(new ProgramError(sb
1809: .toString()));
1810: }
1811: for (int i = 0; i < rank; i++) {
1812: LispObject arg = args[i + 1];
1813: if (arg instanceof Fixnum) {
1814: int subscript = ((Fixnum) arg).getValue();
1815: if (subscript < 0
1816: || subscript >= array.getDimension(i))
1817: return NIL;
1818: } else if (arg instanceof Bignum) {
1819: return NIL;
1820: } else
1821: throw new ConditionThrowable(new TypeError(arg,
1822: "integer"));
1823: }
1824: return T;
1825: }
1826: };
1827:
1828: // ### %array-row-major-index
1829: // %array-row-major-index array subscripts => index
1830: private static final Primitive2 _ARRAY_ROW_MAJOR_INDEX = new Primitive2(
1831: "%array-row-major-index", PACKAGE_SYS, false) {
1832: public LispObject execute(LispObject first, LispObject second)
1833: throws ConditionThrowable {
1834: AbstractArray array = checkArray(first);
1835: LispObject[] subscripts = second.copyToArray();
1836: return number(arrayRowMajorIndex(array, subscripts));
1837: }
1838: };
1839:
1840: // ### aref
1841: // aref array &rest subscripts => element
1842: private static final Primitive AREF = new Primitive("aref") {
1843: public LispObject execute(LispObject arg)
1844: throws ConditionThrowable {
1845: AbstractArray array = checkArray(arg);
1846: if (array.getRank() == 0)
1847: return array.getRowMajor(0);
1848: StringBuffer sb = new StringBuffer("AREF: ");
1849: sb
1850: .append("wrong number of subscripts (0) for array of rank ");
1851: sb.append(array.getRank());
1852: throw new ConditionThrowable(
1853: new ProgramError(sb.toString()));
1854: }
1855:
1856: public LispObject execute(LispObject first, LispObject second)
1857: throws ConditionThrowable {
1858: return first.AREF(second);
1859: }
1860:
1861: public LispObject execute(LispObject[] args)
1862: throws ConditionThrowable {
1863: if (args.length < 1)
1864: throw new ConditionThrowable(
1865: new WrongNumberOfArgumentsException(this ));
1866: AbstractArray array = checkArray(args[0]);
1867: LispObject[] subscripts = new LispObject[args.length - 1];
1868: for (int i = subscripts.length; i-- > 0;)
1869: subscripts[i] = args[i + 1];
1870: int rowMajorIndex = arrayRowMajorIndex(array, subscripts);
1871: return array.getRowMajor(rowMajorIndex);
1872: }
1873: };
1874:
1875: private static final int arrayRowMajorIndex(AbstractArray array,
1876: LispObject[] subscripts) throws ConditionThrowable {
1877: final int rank = array.getRank();
1878: if (rank != subscripts.length) {
1879: StringBuffer sb = new StringBuffer(
1880: "%ARRAY-ROW-MAJOR-INDEX: ");
1881: sb.append("wrong number of subscripts (");
1882: sb.append(subscripts.length);
1883: sb.append(") for array of rank ");
1884: sb.append(rank);
1885: throw new ConditionThrowable(
1886: new ProgramError(sb.toString()));
1887: }
1888: if (rank == 0)
1889: return 0;
1890: int sum = 0;
1891: int size = 1;
1892: for (int i = rank; i-- > 0;) {
1893: int dim = array.getDimension(i);
1894: int lastSize = size;
1895: size *= dim;
1896: LispObject subscript = subscripts[i];
1897: if (subscript instanceof Fixnum) {
1898: int n = ((Fixnum) subscript).getValue();
1899: if (n < 0 || n >= array.getDimension(i))
1900: throw new ConditionThrowable(new ProgramError());
1901: sum += n * lastSize;
1902: } else if (subscript instanceof Bignum) {
1903: throw new ConditionThrowable(new ProgramError());
1904: } else
1905: throw new ConditionThrowable(new TypeError(subscript,
1906: "integer"));
1907: }
1908: return sum;
1909: }
1910:
1911: // ### row-major-aref
1912: // row-major-aref array index => element
1913: private static final Primitive2 ROW_MAJOR_AREF = new Primitive2(
1914: "row-major-aref") {
1915: public LispObject execute(LispObject first, LispObject second)
1916: throws ConditionThrowable {
1917: return checkArray(first).getRowMajor(
1918: Fixnum.getValue(second));
1919: }
1920: };
1921:
1922: // ### %set-row-major-aref
1923: // %set-row-major-aref array index new-value => new-value
1924: private static final Primitive3 _SET_ROW_MAJOR_AREF = new Primitive3(
1925: "%set-row-major-aref", PACKAGE_SYS, false) {
1926: public LispObject execute(LispObject first, LispObject second,
1927: LispObject third) throws ConditionThrowable {
1928: try {
1929: ((AbstractArray) first).setRowMajor(Fixnum
1930: .getValue(second), third);
1931: return third;
1932: } catch (ClassCastException e) {
1933: throw new ConditionThrowable(new TypeError(first,
1934: "array"));
1935: }
1936: }
1937: };
1938:
1939: // ### vector
1940: private static final Primitive VECTOR = new Primitive("vector") {
1941: public LispObject execute(LispObject[] args)
1942: throws ConditionThrowable {
1943: return new Vector(args);
1944: }
1945: };
1946:
1947: // ### %vset
1948: // %vset vector index new-value => new-value
1949: private static final Primitive3 _VSET = new Primitive3("%vset",
1950: PACKAGE_SYS, false) {
1951: public LispObject execute(LispObject first, LispObject second,
1952: LispObject third) throws ConditionThrowable {
1953: try {
1954: ((AbstractVector) first).set(Fixnum.getValue(second),
1955: third);
1956: return third;
1957: } catch (ClassCastException e) {
1958: throw new ConditionThrowable(new TypeError(first,
1959: "vector"));
1960: }
1961: }
1962: };
1963:
1964: // ### svref
1965: // svref simple-vector index => element
1966: private static final Primitive2 SVREF = new Primitive2("svref") {
1967: public LispObject execute(LispObject first, LispObject second)
1968: throws ConditionThrowable {
1969: AbstractVector v = checkVector(first);
1970: if (!v.isSimpleVector())
1971: throw new ConditionThrowable(new TypeError(first,
1972: "simple vector"));
1973: int index = v.checkIndex(second);
1974: return v.get(index);
1975: }
1976: };
1977:
1978: // ### %svset
1979: // %svset simple-vector index new-value => new-value
1980: private static final Primitive3 _SVSET = new Primitive3("%svset",
1981: PACKAGE_SYS, false) {
1982: public LispObject execute(LispObject first, LispObject second,
1983: LispObject third) throws ConditionThrowable {
1984: AbstractVector v = checkVector(first);
1985: if (!v.isSimpleVector())
1986: throw new ConditionThrowable(new TypeError(first,
1987: "simple vector"));
1988: int i = v.checkIndex(second);
1989: v.set(i, third);
1990: return third;
1991: }
1992: };
1993:
1994: // ### fill-pointer
1995: private static final Primitive1 FILL_POINTER = new Primitive1(
1996: "fill-pointer") {
1997: public LispObject execute(LispObject arg)
1998: throws ConditionThrowable {
1999: int fillPointer = checkVector(arg).getFillPointer();
2000: if (fillPointer < 0)
2001: throw new ConditionThrowable(new TypeError(
2002: "array does not have a fill pointer"));
2003: return new Fixnum(fillPointer);
2004: }
2005: };
2006:
2007: // ### %set-fill-pointer
2008: private static final Primitive2 _SET_FILL_POINTER = new Primitive2(
2009: "%set-fill-pointer", PACKAGE_SYS, false) {
2010: public LispObject execute(LispObject first, LispObject second)
2011: throws ConditionThrowable {
2012: AbstractVector v = checkVector(first);
2013: int fillPointer = v.getFillPointer();
2014: if (fillPointer < 0)
2015: throw new ConditionThrowable(new TypeError(
2016: "array does not have a fill pointer"));
2017: v.setFillPointer(second);
2018: return second;
2019: }
2020: };
2021:
2022: // ### vector-push
2023: // vector-push new-element vector => index-of-new-element
2024: private static final Primitive2 VECTOR_PUSH = new Primitive2(
2025: "vector-push") {
2026: public LispObject execute(LispObject first, LispObject second)
2027: throws ConditionThrowable {
2028: AbstractVector v = checkVector(second);
2029: int fillPointer = v.getFillPointer();
2030: if (fillPointer < 0)
2031: throw new ConditionThrowable(new TypeError(
2032: "array does not have a fill pointer"));
2033: if (fillPointer >= v.capacity())
2034: return NIL;
2035: v.set(fillPointer, first);
2036: v.setFillPointer(fillPointer + 1);
2037: return new Fixnum(fillPointer);
2038: }
2039: };
2040:
2041: // ### vector-push-extend
2042: // vector-push new-element vector &optional extension => index-of-new-element
2043: private static final Primitive VECTOR_PUSH_EXTEND = new Primitive(
2044: "vector-push-extend") {
2045: public LispObject execute(LispObject[] args)
2046: throws ConditionThrowable {
2047: if (args.length < 2 || args.length > 3)
2048: throw new ConditionThrowable(
2049: new WrongNumberOfArgumentsException(this ));
2050: AbstractVector v = checkVector(args[1]);
2051: int extension = 0;
2052: if (args.length == 3) {
2053: // Extension was supplied.
2054: extension = Fixnum.getValue(args[2]);
2055: }
2056: int fillPointer = v.getFillPointer();
2057: if (fillPointer < 0)
2058: throw new ConditionThrowable(new TypeError(
2059: "array does not have a fill pointer"));
2060: if (fillPointer >= v.capacity()) {
2061: // Need to extend vector.
2062: extension = Math.max(extension, v.capacity() + 1);
2063: v.ensureCapacity(v.capacity() + extension);
2064: }
2065: v.set(fillPointer, args[0]);
2066: v.setFillPointer(fillPointer + 1);
2067: return new Fixnum(fillPointer);
2068: }
2069: };
2070:
2071: // ### vector-pop
2072: // vector-pop vector => element
2073: private static final Primitive1 VECTOR_POP = new Primitive1(
2074: "vector-pop") {
2075: public LispObject execute(LispObject arg)
2076: throws ConditionThrowable {
2077: AbstractVector v = checkVector(arg);
2078: int fillPointer = v.getFillPointer();
2079: if (fillPointer < 0)
2080: throw new ConditionThrowable(new TypeError(
2081: "array does not have a fill pointer"));
2082: if (fillPointer == 0)
2083: throw new ConditionThrowable(new LispError(
2084: "nothing left to pop"));
2085: int newFillPointer = v.checkIndex(fillPointer - 1);
2086: LispObject element = v.get(newFillPointer);
2087: v.setFillPointer(newFillPointer);
2088: return element;
2089: }
2090: };
2091:
2092: // ### adjust-array
2093: // FIXME Very incomplete!
2094: private static final Primitive2 ADJUST_ARRAY = new Primitive2(
2095: "adjust-array") {
2096: public LispObject execute(LispObject first, LispObject second)
2097: throws ConditionThrowable {
2098: if (first instanceof Vector) {
2099: Vector v = (Vector) first;
2100: LispObject newSize = null;
2101: if (second instanceof Cons) {
2102: if (second.length() == 1)
2103: newSize = second.car();
2104: } else
2105: newSize = second;
2106: if (newSize != null)
2107: return v.adjustArray(Fixnum.getValue(newSize));
2108: }
2109: throw new ConditionThrowable(new LispError(
2110: "ADJUST-ARRAY: unsupported case"));
2111: }
2112: };
2113:
2114: // ### type-of
2115: private static final Primitive1 TYPE_OF = new Primitive1("type-of") {
2116: public LispObject execute(LispObject arg)
2117: throws ConditionThrowable {
2118: return arg.typeOf();
2119: }
2120: };
2121:
2122: // ### class-of
2123: private static final Primitive1 CLASS_OF = new Primitive1(
2124: "class-of") {
2125: public LispObject execute(LispObject arg)
2126: throws ConditionThrowable {
2127: return arg.classOf();
2128: }
2129: };
2130:
2131: // ### simple-typep
2132: private static final Primitive2 SIMPLE_TYPEP = new Primitive2(
2133: "simple-typep", PACKAGE_SYS, false) {
2134: public LispObject execute(LispObject first, LispObject second)
2135: throws ConditionThrowable {
2136: return first.typep(second);
2137: }
2138: };
2139:
2140: // ### function-lambda-expression
2141: // function-lambda-expression function => lambda-expression, closure-p, name
2142: private static final Primitive1 FUNCTION_LAMBDA_EXPRESSION = new Primitive1(
2143: "function-lambda-expression") {
2144: public LispObject execute(LispObject arg)
2145: throws ConditionThrowable {
2146: LispObject[] values = new LispObject[3];
2147: Function function = checkFunction(arg);
2148: String name = function.getName();
2149: values[2] = name != null ? new LispString(name) : NIL;
2150: if (function instanceof Closure) {
2151: Closure closure = (Closure) function;
2152: LispObject expr = closure.getBody();
2153: expr = new Cons(closure.getParameterList(), expr);
2154: expr = new Cons(Symbol.LAMBDA, expr);
2155: values[0] = expr;
2156: Environment env = closure.getEnvironment();
2157: if (env == null || env.isEmpty())
2158: values[1] = NIL;
2159: else
2160: values[1] = T;
2161: } else
2162: values[0] = values[1] = NIL;
2163: LispThread.currentThread().setValues(values);
2164: return values[0];
2165: }
2166: };
2167:
2168: // ### funcall
2169: // This needs to be public for LispAPI.java.
2170: public static final Primitive FUNCALL = new Primitive("funcall") {
2171: public LispObject execute(LispObject arg)
2172: throws ConditionThrowable {
2173: LispObject fun;
2174: if (arg instanceof Symbol)
2175: fun = arg.getSymbolFunction();
2176: else
2177: fun = arg;
2178: if (fun instanceof Function
2179: || fun instanceof GenericFunction)
2180: return funcall0(fun, LispThread.currentThread());
2181: throw new ConditionThrowable(new UndefinedFunction(arg));
2182: }
2183:
2184: public LispObject execute(LispObject first, LispObject second)
2185: throws ConditionThrowable {
2186: LispObject fun;
2187: if (first instanceof Symbol)
2188: fun = first.getSymbolFunction();
2189: else
2190: fun = first;
2191: if (fun instanceof Function
2192: || fun instanceof GenericFunction)
2193: return funcall1(fun, second, LispThread.currentThread());
2194: throw new ConditionThrowable(new UndefinedFunction(first));
2195: }
2196:
2197: public LispObject execute(LispObject first, LispObject second,
2198: LispObject third) throws ConditionThrowable {
2199: LispObject fun;
2200: if (first instanceof Symbol)
2201: fun = first.getSymbolFunction();
2202: else
2203: fun = first;
2204: if (fun instanceof Function
2205: || fun instanceof GenericFunction)
2206: return funcall2(fun, second, third, LispThread
2207: .currentThread());
2208: throw new ConditionThrowable(new UndefinedFunction(first));
2209: }
2210:
2211: public LispObject execute(LispObject[] args)
2212: throws ConditionThrowable {
2213: if (args.length < 1)
2214: throw new ConditionThrowable(
2215: new WrongNumberOfArgumentsException(this ));
2216: LispObject fun;
2217: if (args[0] instanceof Symbol)
2218: fun = args[0].getSymbolFunction();
2219: else
2220: fun = args[0];
2221: if (fun instanceof Function
2222: || fun instanceof GenericFunction) {
2223: final int length = args.length - 1; // Number of arguments.
2224: if (length == 3) {
2225: return funcall3(fun, args[1], args[2], args[3],
2226: LispThread.currentThread());
2227: } else {
2228: LispObject[] funArgs = new LispObject[length];
2229: System.arraycopy(args, 1, funArgs, 0, length);
2230: return funcall(fun, funArgs, LispThread
2231: .currentThread());
2232: }
2233: }
2234: throw new ConditionThrowable(new UndefinedFunction(args[0]));
2235: }
2236: };
2237:
2238: // ### apply
2239: public static final Primitive APPLY = new Primitive("apply") {
2240: public LispObject execute(LispObject first, LispObject second)
2241: throws ConditionThrowable {
2242: LispObject spread = checkList(second);
2243: LispObject fun = first;
2244: if (fun instanceof Symbol)
2245: fun = fun.getSymbolFunction();
2246: if (fun instanceof Function
2247: || fun instanceof GenericFunction) {
2248: final int numFunArgs = spread.length();
2249: final LispThread thread = LispThread.currentThread();
2250: switch (numFunArgs) {
2251: case 1:
2252: return funcall1(fun, spread.car(), thread);
2253: case 2:
2254: return funcall2(fun, spread.car(), spread.cadr(),
2255: thread);
2256: case 3:
2257: return funcall3(fun, spread.car(), spread.cadr(),
2258: spread.cdr().cdr().car(), thread);
2259: default: {
2260: final LispObject[] funArgs = new LispObject[numFunArgs];
2261: int j = 0;
2262: while (spread != NIL) {
2263: funArgs[j++] = spread.car();
2264: spread = spread.cdr();
2265: }
2266: return funcall(fun, funArgs, thread);
2267: }
2268: }
2269: }
2270: throw new ConditionThrowable(new TypeError(fun, "function"));
2271: }
2272:
2273: public LispObject execute(final LispObject[] args)
2274: throws ConditionThrowable {
2275: final int numArgs = args.length;
2276: if (numArgs < 2)
2277: throw new ConditionThrowable(
2278: new WrongNumberOfArgumentsException(this ));
2279: LispObject spread = checkList(args[numArgs - 1]);
2280: LispObject fun = args[0];
2281: if (fun instanceof Symbol)
2282: fun = fun.getSymbolFunction();
2283: if (fun instanceof Function
2284: || fun instanceof GenericFunction) {
2285: final int numFunArgs = numArgs - 2 + spread.length();
2286: final LispObject[] funArgs = new LispObject[numFunArgs];
2287: int j = 0;
2288: for (int i = 1; i < numArgs - 1; i++)
2289: funArgs[j++] = args[i];
2290: while (spread != NIL) {
2291: funArgs[j++] = spread.car();
2292: spread = spread.cdr();
2293: }
2294: return funcall(fun, funArgs, LispThread.currentThread());
2295: }
2296: throw new ConditionThrowable(new TypeError(fun, "function"));
2297: }
2298: };
2299:
2300: // ### mapcar
2301: private static final Primitive MAPCAR = new Primitive("mapcar") {
2302: public LispObject execute(LispObject op, LispObject list)
2303: throws ConditionThrowable {
2304: LispObject fun;
2305: if (op instanceof Symbol)
2306: fun = op.getSymbolFunction();
2307: else
2308: fun = op;
2309: if (fun instanceof Function
2310: || fun instanceof GenericFunction) {
2311: final LispThread thread = LispThread.currentThread();
2312: LispObject result = NIL;
2313: LispObject splice = null;
2314: while (list != NIL) {
2315: LispObject obj = funcall1(fun, list.car(), thread);
2316: if (splice == null) {
2317: result = new Cons(obj, result);
2318: splice = result;
2319: } else {
2320: Cons cons = new Cons(obj);
2321: splice.setCdr(cons);
2322: splice = cons;
2323: }
2324: list = list.cdr();
2325: }
2326: return result;
2327: }
2328: throw new ConditionThrowable(new UndefinedFunction(op));
2329: }
2330:
2331: public LispObject execute(LispObject first, LispObject second,
2332: LispObject third) throws ConditionThrowable {
2333: // First argument must be a function.
2334: LispObject fun = first;
2335: if (fun instanceof Symbol)
2336: fun = fun.getSymbolFunction();
2337: if (!(fun instanceof Function || fun instanceof GenericFunction))
2338: throw new ConditionThrowable(new UndefinedFunction(
2339: first));
2340: // Remaining arguments must be lists.
2341: LispObject list1 = checkList(second);
2342: LispObject list2 = checkList(third);
2343: final LispThread thread = LispThread.currentThread();
2344: LispObject result = NIL;
2345: LispObject splice = null;
2346: while (list1 != NIL && list2 != NIL) {
2347: LispObject obj = funcall2(fun, list1.car(),
2348: list2.car(), thread);
2349: if (splice == null) {
2350: result = new Cons(obj, result);
2351: splice = result;
2352: } else {
2353: Cons cons = new Cons(obj);
2354: splice.setCdr(cons);
2355: splice = cons;
2356: }
2357: list1 = list1.cdr();
2358: list2 = list2.cdr();
2359: }
2360: return result;
2361: }
2362:
2363: public LispObject execute(final LispObject[] args)
2364: throws ConditionThrowable {
2365: final int numArgs = args.length;
2366: if (numArgs < 2)
2367: throw new ConditionThrowable(
2368: new WrongNumberOfArgumentsException(this ));
2369: // First argument must be a function.
2370: LispObject fun = args[0];
2371: if (fun instanceof Symbol)
2372: fun = fun.getSymbolFunction();
2373: if (!(fun instanceof Function || fun instanceof GenericFunction))
2374: throw new ConditionThrowable(new UndefinedFunction(
2375: args[0]));
2376: // Remaining arguments must be lists.
2377: int commonLength = -1;
2378: for (int i = 1; i < numArgs; i++) {
2379: if (!args[i].listp())
2380: throw new ConditionThrowable(new TypeError(args[i],
2381: "list"));
2382: int len = args[i].length();
2383: if (commonLength < 0)
2384: commonLength = len;
2385: else if (commonLength > len)
2386: commonLength = len;
2387: }
2388: final LispThread thread = LispThread.currentThread();
2389: LispObject[] results = new LispObject[commonLength];
2390: final int numFunArgs = numArgs - 1;
2391: final LispObject[] funArgs = new LispObject[numFunArgs];
2392: for (int i = 0; i < commonLength; i++) {
2393: for (int j = 0; j < numFunArgs; j++)
2394: funArgs[j] = args[j + 1].car();
2395: results[i] = funcall(fun, funArgs, thread);
2396: for (int j = 1; j < numArgs; j++)
2397: args[j] = args[j].cdr();
2398: }
2399: LispObject result = NIL;
2400: for (int i = commonLength; i-- > 0;)
2401: result = new Cons(results[i], result);
2402: return result;
2403: }
2404: };
2405:
2406: // ### macroexpand
2407: private static final Primitive MACROEXPAND = new Primitive(
2408: "macroexpand") {
2409: public LispObject execute(LispObject[] args)
2410: throws ConditionThrowable {
2411: final int length = args.length;
2412: if (length < 1 || length > 2)
2413: throw new ConditionThrowable(
2414: new WrongNumberOfArgumentsException(this ));
2415: LispObject form = args[0];
2416: final Environment env;
2417: if (length == 2 && args[1] != NIL)
2418: env = checkEnvironment(args[1]);
2419: else
2420: env = new Environment();
2421: return macroexpand(form, env, LispThread.currentThread());
2422: }
2423: };
2424:
2425: // ### macroexpand-1
2426: private static final Primitive MACROEXPAND_1 = new Primitive(
2427: "macroexpand-1") {
2428: public LispObject execute(LispObject form)
2429: throws ConditionThrowable {
2430: return macroexpand_1(form, new Environment(), LispThread
2431: .currentThread());
2432: }
2433:
2434: public LispObject execute(LispObject form, LispObject env)
2435: throws ConditionThrowable {
2436: return macroexpand_1(form,
2437: env != NIL ? checkEnvironment(env)
2438: : new Environment(), LispThread
2439: .currentThread());
2440: }
2441: };
2442:
2443: // ### *gensym-counter*
2444: private static final Symbol _GENSYM_COUNTER_ = PACKAGE_CL
2445: .addExternalSymbol("*GENSYM-COUNTER*");
2446: static {
2447: _GENSYM_COUNTER_.setSymbolValue(Fixnum.ZERO);
2448: _GENSYM_COUNTER_.setSpecial(true);
2449: }
2450:
2451: // ### gensym
2452: private static final Primitive GENSYM = new Primitive("gensym") {
2453: public LispObject execute() throws ConditionThrowable {
2454: return gensym("G");
2455: }
2456:
2457: public LispObject execute(LispObject arg)
2458: throws ConditionThrowable {
2459: String prefix = "G";
2460: if (arg instanceof Fixnum) {
2461: int n = ((Fixnum) arg).getValue();
2462: if (n < 0)
2463: throw new ConditionThrowable(new TypeError(arg,
2464: "non-negative integer"));
2465: StringBuffer sb = new StringBuffer(prefix);
2466: sb.append(n);
2467: return new Symbol(sb.toString());
2468: }
2469: if (arg instanceof Bignum) {
2470: BigInteger n = ((Bignum) arg).getValue();
2471: if (n.signum() < 0)
2472: throw new ConditionThrowable(new TypeError(arg,
2473: "non-negative integer"));
2474: StringBuffer sb = new StringBuffer(prefix);
2475: sb.append(n.toString());
2476: return new Symbol(sb.toString());
2477: }
2478: if (arg instanceof LispString)
2479: prefix = ((LispString) arg).getValue();
2480: else
2481: throw new ConditionThrowable(new TypeError(arg,
2482: "string or non-negative integer"));
2483: return gensym(prefix);
2484: }
2485: };
2486:
2487: private static final Symbol gensym(String prefix)
2488: throws ConditionThrowable {
2489: LispThread thread = LispThread.currentThread();
2490: Environment dynEnv = thread.getDynamicEnvironment();
2491: Binding binding = (dynEnv == null) ? null : dynEnv
2492: .getBinding(_GENSYM_COUNTER_);
2493: LispObject oldValue;
2494: if (binding != null) {
2495: oldValue = binding.value;
2496: binding.value = oldValue.incr();
2497: } else {
2498: oldValue = _GENSYM_COUNTER_.getSymbolValue();
2499: _GENSYM_COUNTER_.setSymbolValue(oldValue.incr());
2500: }
2501: StringBuffer sb = new StringBuffer(prefix);
2502: sb.append(String.valueOf(oldValue));
2503: return new Symbol(sb.toString());
2504: }
2505:
2506: // ### string
2507: private static final Primitive1 STRING = new Primitive1("string") {
2508: public LispObject execute(LispObject arg)
2509: throws ConditionThrowable {
2510: return string(arg);
2511: }
2512: };
2513:
2514: // ### intern
2515: // intern string &optional package => symbol, status
2516: // status is one of :INHERITED, :EXTERNAL, :INTERNAL or NIL.
2517: private static final Primitive INTERN = new Primitive("intern") {
2518: public LispObject execute(LispObject[] args)
2519: throws ConditionThrowable {
2520: final LispThread thread = LispThread.currentThread();
2521: switch (args.length) {
2522: case 1: {
2523: Package pkg = (Package) _PACKAGE_
2524: .symbolValueNoThrow(thread);
2525: return pkg.intern(LispString.getValue(args[0]), thread);
2526: }
2527: case 2: {
2528: Package pkg = coerceToPackage(args[1]);
2529: return pkg.intern(LispString.getValue(args[0]), thread);
2530: }
2531: default:
2532: throw new ConditionThrowable(
2533: new WrongNumberOfArgumentsException(this ));
2534: }
2535: }
2536: };
2537:
2538: // ### unintern
2539: // unintern symbol &optional package => generalized-boolean
2540: private static final Primitive UNINTERN = new Primitive("unintern") {
2541: public LispObject execute(LispObject[] args)
2542: throws ConditionThrowable {
2543: if (args.length == 0 || args.length > 2)
2544: throw new ConditionThrowable(
2545: new WrongNumberOfArgumentsException(this ));
2546: Symbol symbol = checkSymbol(args[0]);
2547: Package pkg;
2548: if (args.length == 2)
2549: pkg = coerceToPackage(args[1]);
2550: else
2551: pkg = getCurrentPackage();
2552: return pkg.unintern(symbol);
2553: }
2554: };
2555:
2556: // ### find-package
2557: private static final Primitive1 FIND_PACKAGE = new Primitive1(
2558: "find-package") {
2559: public LispObject execute(LispObject arg)
2560: throws ConditionThrowable {
2561: if (arg instanceof Package)
2562: return arg;
2563: if (arg instanceof LispString) {
2564: Package pkg = Packages.findPackage(((LispString) arg)
2565: .getValue());
2566: return pkg != null ? pkg : NIL;
2567: }
2568: if (arg instanceof Symbol) {
2569: Package pkg = Packages.findPackage(arg.getName());
2570: return pkg != null ? pkg : NIL;
2571: }
2572: if (arg instanceof LispCharacter) {
2573: String packageName = String
2574: .valueOf(new char[] { ((LispCharacter) arg)
2575: .getValue() });
2576: Package pkg = Packages.findPackage(packageName);
2577: return pkg != null ? pkg : NIL;
2578: }
2579: return NIL;
2580: }
2581: };
2582:
2583: // ### %make-package
2584: // %make-package package-name nicknames use => package
2585: private static final Primitive3 _MAKE_PACKAGE = new Primitive3(
2586: "%make-package", PACKAGE_SYS, false) {
2587: public LispObject execute(LispObject first, LispObject second,
2588: LispObject third) throws ConditionThrowable {
2589: String packageName = javaString(first);
2590: Package pkg = Packages.findPackage(packageName);
2591: if (pkg != null)
2592: throw new ConditionThrowable(new LispError("package "
2593: + packageName + " already exists"));
2594: LispObject nicknames = checkList(second);
2595: if (nicknames != NIL) {
2596: LispObject list = nicknames;
2597: while (list != NIL) {
2598: String nick = javaString(list.car());
2599: if (Packages.findPackage(nick) != null) {
2600: throw new ConditionThrowable(new PackageError(
2601: "a package named " + nick
2602: + " already exists"));
2603: }
2604: list = list.cdr();
2605: }
2606: }
2607: LispObject use = checkList(third);
2608: if (use != NIL) {
2609: LispObject list = use;
2610: while (list != NIL) {
2611: LispObject obj = list.car();
2612: if (obj instanceof Package)
2613: ; // OK.
2614: else {
2615: String s = javaString(obj);
2616: Package p = Packages.findPackage(s);
2617: if (p == null)
2618: throw new ConditionThrowable(new LispError(
2619: String.valueOf(obj))
2620: + " is not the name of a package");
2621: }
2622: list = list.cdr();
2623: }
2624: }
2625: // Now create the package.
2626: pkg = Packages.createPackage(packageName);
2627: // Add the nicknames.
2628: while (nicknames != NIL) {
2629: String nick = javaString(nicknames.car());
2630: pkg.addNickname(nick);
2631: nicknames = nicknames.cdr();
2632: }
2633: // Create the use list.
2634: while (use != NIL) {
2635: LispObject obj = use.car();
2636: if (obj instanceof Package)
2637: pkg.usePackage((Package) obj);
2638: else {
2639: String s = javaString(obj);
2640: Package p = Packages.findPackage(s);
2641: if (p == null)
2642: throw new ConditionThrowable(new LispError(
2643: String.valueOf(obj))
2644: + " is not the name of a package");
2645: pkg.usePackage(p);
2646: }
2647: use = use.cdr();
2648: }
2649: return pkg;
2650: }
2651: };
2652:
2653: // ### %in-package
2654: private static final Primitive1 _IN_PACKAGE = new Primitive1(
2655: "%in-package", PACKAGE_SYS, false) {
2656: public LispObject execute(LispObject arg)
2657: throws ConditionThrowable {
2658: String packageName = javaString(arg);
2659: Package pkg = Packages.findPackage(packageName);
2660: if (pkg == null)
2661: throw new ConditionThrowable(new PackageError(
2662: "package " + arg + " does not exist"));
2663: LispThread thread = LispThread.currentThread();
2664: Environment dynEnv = thread.getDynamicEnvironment();
2665: if (dynEnv != null) {
2666: Binding binding = dynEnv.getBinding(_PACKAGE_);
2667: if (binding != null) {
2668: binding.value = pkg;
2669: return pkg;
2670: }
2671: }
2672: // No dynamic binding.
2673: _PACKAGE_.setSymbolValue(pkg);
2674: return pkg;
2675: }
2676: };
2677:
2678: // ### use-package
2679: // use-package packages-to-use &optional package => t
2680: private static final Primitive USE_PACKAGE = new Primitive(
2681: "use-package") {
2682: public LispObject execute(LispObject[] args)
2683: throws ConditionThrowable {
2684: if (args.length < 1 || args.length > 2)
2685: throw new ConditionThrowable(
2686: new WrongNumberOfArgumentsException(this ));
2687: Package pkg;
2688: if (args.length == 2)
2689: pkg = coerceToPackage(args[1]);
2690: else
2691: pkg = getCurrentPackage();
2692: if (args[0] instanceof Cons) {
2693: LispObject list = args[0];
2694: while (list != NIL) {
2695: pkg.usePackage(coerceToPackage(list.car()));
2696: list = list.cdr();
2697: }
2698: } else
2699: pkg.usePackage(coerceToPackage(args[0]));
2700: return T;
2701: }
2702: };
2703:
2704: // ### do-external-symbols
2705: // do-external-symbols (var [package [result-form]]) declaration* {tag | statement}*
2706: // => result*
2707: // Should be a macro.
2708: private static final SpecialOperator DO_EXTERNAL_SYMBOLS = new SpecialOperator(
2709: "do-external-symbols") {
2710: public LispObject execute(LispObject args, Environment env)
2711: throws ConditionThrowable {
2712: return doSymbols(args, env, true);
2713: }
2714: };
2715:
2716: // ### do-symbols
2717: // do-symbols (var [package [result-form]]) declaration* {tag | statement}*
2718: // => result*
2719: // Should be a macro.
2720: private static final SpecialOperator DO_SYMBOLS = new SpecialOperator(
2721: "do-symbols") {
2722: public LispObject execute(LispObject args, Environment env)
2723: throws ConditionThrowable {
2724: return doSymbols(args, env, false);
2725: }
2726: };
2727:
2728: private static final LispObject doSymbols(LispObject args,
2729: Environment env, boolean externalOnly)
2730: throws ConditionThrowable {
2731: LispObject bodyForm = args.cdr();
2732: args = args.car();
2733: Symbol var = checkSymbol(args.car());
2734: args = args.cdr();
2735: final LispThread thread = LispThread.currentThread();
2736: // Defaults.
2737: Package pkg = getCurrentPackage();
2738: LispObject resultForm = NIL;
2739: if (args != NIL) {
2740: pkg = coerceToPackage(eval(args.car(), env, thread));
2741: args = args.cdr();
2742: if (args != NIL)
2743: resultForm = args.car();
2744: }
2745: Environment oldDynEnv = thread.getDynamicEnvironment();
2746: final List list;
2747: if (externalOnly)
2748: list = pkg.getExternalSymbols();
2749: else
2750: list = pkg.getAccessibleSymbols();
2751: for (Iterator it = list.iterator(); it.hasNext();) {
2752: Symbol symbol = (Symbol) it.next();
2753: Environment ext = new Environment(env);
2754: bind(var, symbol, ext);
2755: LispObject body = bodyForm;
2756: int depth = thread.getStackDepth();
2757: try {
2758: while (body != NIL) {
2759: eval(body.car(), ext, thread);
2760: body = body.cdr();
2761: }
2762: } catch (Return ret) {
2763: if (ret.getTag() == NIL) {
2764: thread.setStackDepth(depth);
2765: return ret.getResult();
2766: }
2767: throw ret;
2768: }
2769: }
2770: Environment ext = new Environment(env);
2771: bind(var, NIL, ext);
2772: LispObject result = eval(resultForm, ext, thread);
2773: thread.setDynamicEnvironment(oldDynEnv);
2774: return result;
2775: }
2776:
2777: // ### package-symbols
2778: private static final Primitive1 PACKAGE_SYMBOLS = new Primitive1(
2779: "package-symbols", PACKAGE_SYS, false) {
2780: public LispObject execute(LispObject arg)
2781: throws ConditionThrowable {
2782: return coerceToPackage(arg).getSymbols();
2783: }
2784: };
2785:
2786: // ### package-internal-symbols
2787: private static final Primitive1 PACKAGE_INTERNAL_SYMBOLS = new Primitive1(
2788: "package-internal-symbols", PACKAGE_SYS, false) {
2789: public LispObject execute(LispObject arg)
2790: throws ConditionThrowable {
2791: return coerceToPackage(arg).PACKAGE_INTERNAL_SYMBOLS();
2792: }
2793: };
2794:
2795: // ### package-external-symbols
2796: private static final Primitive1 PACKAGE_EXTERNAL_SYMBOLS = new Primitive1(
2797: "package-external-symbols", PACKAGE_SYS, false) {
2798: public LispObject execute(LispObject arg)
2799: throws ConditionThrowable {
2800: return coerceToPackage(arg).PACKAGE_EXTERNAL_SYMBOLS();
2801: }
2802: };
2803:
2804: // ### package-inherited-symbols
2805: private static final Primitive1 PACKAGE_INHERITED_SYMBOLS = new Primitive1(
2806: "package-inherited-symbols", PACKAGE_SYS, false) {
2807: public LispObject execute(LispObject arg)
2808: throws ConditionThrowable {
2809: return coerceToPackage(arg).PACKAGE_INHERITED_SYMBOLS();
2810: }
2811: };
2812:
2813: // ### export
2814: // export symbols &optional package
2815: private static final Primitive EXPORT = new Primitive("export") {
2816: public LispObject execute(LispObject[] args)
2817: throws ConditionThrowable {
2818: if (args.length == 0 || args.length > 2)
2819: throw new ConditionThrowable(
2820: new WrongNumberOfArgumentsException(this ));
2821: Package pkg;
2822: if (args.length == 2)
2823: pkg = coerceToPackage(args[1]);
2824: else
2825: pkg = (Package) _PACKAGE_.symbolValue();
2826: // args[0] can be a single symbol or a list.
2827: if (args[0] instanceof Cons) {
2828: for (LispObject list = args[0]; list != NIL; list = list
2829: .cdr())
2830: pkg.export(checkSymbol(list.car()));
2831: } else
2832: pkg.export(checkSymbol(args[0]));
2833: return T;
2834: }
2835: };
2836:
2837: // ### find-symbol
2838: // find-symbol string &optional package => symbol, status
2839: private static final Primitive FIND_SYMBOL = new Primitive(
2840: "find-symbol") {
2841: public LispObject execute(LispObject[] args)
2842: throws ConditionThrowable {
2843: if (args.length == 0 || args.length > 2)
2844: throw new ConditionThrowable(
2845: new WrongNumberOfArgumentsException(this ));
2846: String name = LispString.getValue(args[0]);
2847: Package pkg;
2848: if (args.length == 2)
2849: pkg = coerceToPackage(args[1]);
2850: else
2851: pkg = getCurrentPackage();
2852: return pkg.findSymbol(name);
2853: }
2854: };
2855:
2856: // ### fset
2857: private static final Primitive2 FSET = new Primitive2("fset",
2858: PACKAGE_SYS, false) {
2859: public LispObject execute(LispObject first, LispObject second)
2860: throws ConditionThrowable {
2861: Symbol symbol = checkSymbol(first);
2862: if (second instanceof LispString) {
2863: String className = ((LispString) second).getValue();
2864: if (className.endsWith(".class")) {
2865: try {
2866: JavaClassLoader loader = new JavaClassLoader();
2867: Class c = loader.loadClassFromFile(className);
2868: if (c != null) {
2869: Class[] parameterTypes = new Class[0];
2870: java.lang.reflect.Constructor constructor = c
2871: .getConstructor(parameterTypes);
2872: Object[] initargs = new Object[0];
2873: LispObject obj = (LispObject) constructor
2874: .newInstance(initargs);
2875: symbol.setSymbolFunction(obj);
2876: return obj;
2877: }
2878: } catch (Throwable t) {
2879: Debug.trace(t);
2880: }
2881: }
2882: throw new ConditionThrowable(new LispError(
2883: "unable to load ".concat(className)));
2884: }
2885: symbol.setSymbolFunction(second);
2886: return second;
2887: }
2888: };
2889:
2890: // ### %set-symbol-plist
2891: private static final Primitive2 _SET_SYMBOL_PLIST = new Primitive2(
2892: "%set-symbol-plist", PACKAGE_SYS, false) {
2893: public LispObject execute(LispObject first, LispObject second)
2894: throws ConditionThrowable {
2895: checkSymbol(first).setPropertyList(checkList(second));
2896: return second;
2897: }
2898: };
2899:
2900: // ### getf
2901: // getf plist indicator &optional default => value
2902: private static final Primitive GETF = new Primitive("getf") {
2903: public LispObject execute(LispObject plist, LispObject indicator)
2904: throws ConditionThrowable {
2905: return getf(plist, indicator, NIL);
2906: }
2907:
2908: public LispObject execute(LispObject plist,
2909: LispObject indicator, LispObject defaultValue)
2910: throws ConditionThrowable {
2911: return getf(plist, indicator, defaultValue);
2912: }
2913: };
2914:
2915: // ### get
2916: // get symbol indicator &optional default => value
2917: private static final Primitive GET = new Primitive("get") {
2918: public LispObject execute(LispObject symbol,
2919: LispObject indicator) throws ConditionThrowable {
2920: return get(checkSymbol(symbol), indicator, NIL);
2921: }
2922:
2923: public LispObject execute(LispObject symbol,
2924: LispObject indicator, LispObject defaultValue)
2925: throws ConditionThrowable {
2926: return get(checkSymbol(symbol), indicator, defaultValue);
2927: }
2928: };
2929:
2930: // ### %put
2931: // %put symbol indicator value => value
2932: private static final Primitive3 _PUT = new Primitive3("%put",
2933: PACKAGE_SYS, false) {
2934: public LispObject execute(LispObject symbol,
2935: LispObject indicator, LispObject value)
2936: throws ConditionThrowable {
2937: return put(checkSymbol(symbol), indicator, value);
2938: }
2939: };
2940:
2941: // ### macrolet
2942: private static final SpecialOperator MACROLET = new SpecialOperator(
2943: "macrolet") {
2944: public LispObject execute(LispObject args, Environment env)
2945: throws ConditionThrowable {
2946: LispObject defs = checkList(args.car());
2947: final LispThread thread = LispThread.currentThread();
2948: LispObject result;
2949: if (defs != NIL) {
2950: Environment ext = new Environment(env);
2951: while (defs != NIL) {
2952: LispObject def = checkList(defs.car());
2953: Symbol symbol = checkSymbol(def.car());
2954: LispObject lambdaList = def.cadr();
2955: LispObject body = def.cddr();
2956: LispObject block = new Cons(Symbol.BLOCK, new Cons(
2957: symbol, body));
2958: LispObject toBeApplied = list3(Symbol.LAMBDA,
2959: lambdaList, block);
2960: LispObject formArg = gensym("FORM-");
2961: LispObject envArg = gensym("ENV-"); // Ignored.
2962: LispObject expander = list3(Symbol.LAMBDA, list2(
2963: formArg, envArg), list3(Symbol.APPLY,
2964: toBeApplied, list2(Symbol.CDR, formArg)));
2965: Closure expansionFunction = new Closure(expander
2966: .cadr(), expander.cddr(), env);
2967: MacroObject macroObject = new MacroObject(
2968: expansionFunction);
2969: ext.bindFunctional(symbol, macroObject);
2970: defs = defs.cdr();
2971: }
2972: result = progn(args.cdr(), ext, thread);
2973: } else
2974: result = progn(args.cdr(), env, thread);
2975: return result;
2976: }
2977: };
2978:
2979: // ### tagbody
2980: private static final SpecialOperator TAGBODY = new SpecialOperator(
2981: "tagbody") {
2982: public LispObject execute(LispObject args, Environment env)
2983: throws ConditionThrowable {
2984: Binding tags = null;
2985: LispObject body = args;
2986: while (body != NIL) {
2987: LispObject current = body.car();
2988: body = body.cdr();
2989: if (current instanceof Cons)
2990: continue;
2991: // It's a tag.
2992: tags = new Binding(current, body, tags);
2993: }
2994: final LispThread thread = LispThread.currentThread();
2995: final int depth = thread.getStackDepth();
2996: LispObject remaining = args;
2997: while (remaining != NIL) {
2998: LispObject current = remaining.car();
2999: if (current instanceof Cons) {
3000: try {
3001: // Handle GO inline if possible.
3002: if (current.car() == Symbol.GO) {
3003: LispObject code = null;
3004: LispObject tag = current.cadr();
3005: for (Binding binding = tags; binding != null; binding = binding.next) {
3006: if (binding.symbol.eql(tag)) {
3007: code = binding.value;
3008: break;
3009: }
3010: }
3011: if (code != null) {
3012: remaining = code;
3013: continue;
3014: }
3015: throw new Go(tag);
3016: }
3017: eval(current, env, thread);
3018: } catch (Go go) {
3019: LispObject code = null;
3020: LispObject tag = go.getTag();
3021: for (Binding binding = tags; binding != null; binding = binding.next) {
3022: if (binding.symbol.eql(tag)) {
3023: code = binding.value;
3024: break;
3025: }
3026: }
3027: if (code != null) {
3028: remaining = code;
3029: thread.setStackDepth(depth);
3030: continue;
3031: }
3032: throw go;
3033: }
3034: }
3035: remaining = remaining.cdr();
3036: }
3037: thread.clearValues();
3038: return NIL;
3039: }
3040: };
3041:
3042: // ### go
3043: private static final SpecialOperator GO = new SpecialOperator("go") {
3044: public LispObject execute(LispObject args, Environment env)
3045: throws ConditionThrowable {
3046: if (args.length() != 1)
3047: throw new ConditionThrowable(
3048: new WrongNumberOfArgumentsException(this ));
3049: throw new Go(args.car());
3050: }
3051: };
3052:
3053: // ### block
3054: private static final SpecialOperator BLOCK = new SpecialOperator(
3055: "block") {
3056: public LispObject execute(LispObject args, Environment env)
3057: throws ConditionThrowable {
3058: if (args == NIL)
3059: throw new ConditionThrowable(
3060: new WrongNumberOfArgumentsException(this ));
3061: LispObject tag;
3062: if (args.car() == NIL)
3063: tag = NIL;
3064: else
3065: tag = checkSymbol(args.car());
3066: LispObject body = args.cdr();
3067: Block block = new Block(tag, body);
3068: Environment ext = new Environment(env);
3069: ext.addBlock(tag, block);
3070: LispObject result = NIL;
3071: final LispThread thread = LispThread.currentThread();
3072: final int depth = thread.getStackDepth();
3073: try {
3074: while (body != NIL) {
3075: result = eval(body.car(), ext, thread);
3076: body = body.cdr();
3077: }
3078: return result;
3079: } catch (Return ret) {
3080: if (ret.getBlock() != null) {
3081: if (ret.getBlock() == block) {
3082: thread.setStackDepth(depth);
3083: return ret.getResult();
3084: } else
3085: throw ret;
3086: }
3087: if (ret.getTag() == tag) {
3088: thread.setStackDepth(depth);
3089: return ret.getResult();
3090: }
3091: throw ret;
3092: }
3093: }
3094: };
3095:
3096: // ### return-from
3097: private static final SpecialOperator RETURN_FROM = new SpecialOperator(
3098: "return-from") {
3099: public LispObject execute(LispObject args, Environment env)
3100: throws ConditionThrowable {
3101: final int length = args.length();
3102: if (length < 1 || length > 2)
3103: throw new ConditionThrowable(
3104: new WrongNumberOfArgumentsException(this ));
3105: Symbol symbol = checkSymbol(args.car());
3106: Block block = env.lookupBlock(symbol);
3107: if (block == null) {
3108: StringBuffer sb = new StringBuffer("no block named ");
3109: sb.append(symbol.getName());
3110: sb.append(" is currently visible");
3111: throw new ConditionThrowable(new LispError(sb
3112: .toString()));
3113: }
3114: LispObject result;
3115: if (length == 2)
3116: result = eval(args.cadr(), env, LispThread
3117: .currentThread());
3118: else
3119: result = NIL;
3120: throw new Return(symbol, block, result);
3121: }
3122: };
3123:
3124: // ### return
3125: // Should be a macro.
3126: private static final SpecialOperator RETURN = new SpecialOperator(
3127: "return") {
3128: public LispObject execute(LispObject args, Environment env)
3129: throws ConditionThrowable {
3130: switch (args.length()) {
3131: case 0:
3132: throw new Return(NIL, NIL);
3133: case 1:
3134: throw new Return(NIL, eval(args.car(), env, LispThread
3135: .currentThread()));
3136: default:
3137: throw new ConditionThrowable(
3138: new WrongNumberOfArgumentsException(this ));
3139: }
3140: }
3141: };
3142:
3143: // ### catch
3144: private static final SpecialOperator CATCH = new SpecialOperator(
3145: "catch") {
3146: public LispObject execute(LispObject args, Environment env)
3147: throws ConditionThrowable {
3148: if (args.length() < 1)
3149: throw new ConditionThrowable(
3150: new WrongNumberOfArgumentsException(this ));
3151: final LispThread thread = LispThread.currentThread();
3152: LispObject tag = eval(args.car(), env, thread);
3153: thread.pushCatchTag(tag);
3154: LispObject body = args.cdr();
3155: LispObject result = NIL;
3156: final int depth = thread.getStackDepth();
3157: try {
3158: while (body != NIL) {
3159: result = eval(body.car(), env, thread);
3160: body = body.cdr();
3161: }
3162: return result;
3163: } catch (Throw t) {
3164: if (t.getTag() == tag) {
3165: thread.setStackDepth(depth);
3166: return t.getResult();
3167: }
3168: throw t;
3169: } catch (Return ret) {
3170: throw ret;
3171: } finally {
3172: thread.popCatchTag();
3173: }
3174: }
3175: };
3176:
3177: // ### throw
3178: private static final SpecialOperator THROW = new SpecialOperator(
3179: "throw") {
3180: public LispObject execute(LispObject args, Environment env)
3181: throws ConditionThrowable {
3182: if (args.length() < 2)
3183: throw new ConditionThrowable(
3184: new WrongNumberOfArgumentsException(this ));
3185: final LispThread thread = LispThread.currentThread();
3186: LispObject tag = eval(args.car(), env, thread);
3187: LispObject result = eval(args.cadr(), env, thread);
3188: throw new Throw(tag, result);
3189: }
3190: };
3191:
3192: // ### unwind-protect
3193: private static final SpecialOperator UNWIND_PROTECT = new SpecialOperator(
3194: "unwind-protect") {
3195: public LispObject execute(LispObject args, Environment env)
3196: throws ConditionThrowable {
3197: final LispThread thread = LispThread.currentThread();
3198: LispObject result;
3199: LispObject[] values;
3200: try {
3201: result = eval(args.car(), env, thread);
3202: values = thread.getValues();
3203: } finally {
3204: LispObject body = args.cdr();
3205: while (body != NIL) {
3206: eval(body.car(), env, thread);
3207: body = body.cdr();
3208: }
3209: }
3210: thread.setValues(values);
3211: return result;
3212: }
3213: };
3214:
3215: // ### eval-when
3216: private static final SpecialOperator EVAL_WHEN = new SpecialOperator(
3217: "eval-when") {
3218: public LispObject execute(LispObject args, Environment env)
3219: throws ConditionThrowable {
3220: return progn(args.cdr(), env, LispThread.currentThread());
3221: }
3222: };
3223:
3224: // ### multiple-value-bind
3225: // multiple-value-bind (var*) values-form declaration* form*
3226: // Should be a macro.
3227: private static final SpecialOperator MULTIPLE_VALUE_BIND = new SpecialOperator(
3228: "multiple-value-bind") {
3229: public LispObject execute(LispObject args, Environment env)
3230: throws ConditionThrowable {
3231: LispObject vars = args.car();
3232: args = args.cdr();
3233: LispObject valuesForm = args.car();
3234: final LispThread thread = LispThread.currentThread();
3235: LispObject value = eval(valuesForm, env, thread);
3236: LispObject[] values = thread.getValues();
3237: if (values == null) {
3238: // eval() did not return multiple values.
3239: values = new LispObject[1];
3240: values[0] = value;
3241: }
3242: Environment oldDynEnv = thread.getDynamicEnvironment();
3243: Environment ext = new Environment(env);
3244: int i = 0;
3245: LispObject var = vars.car();
3246: while (var != NIL) {
3247: Symbol symbol = checkSymbol(var);
3248: if (i < values.length)
3249: bind(symbol, values[i], ext);
3250: else
3251: bind(symbol, NIL, ext);
3252: vars = vars.cdr();
3253: var = vars.car();
3254: ++i;
3255: }
3256: LispObject result = NIL;
3257: LispObject body = args.cdr();
3258: while (body != NIL) {
3259: result = eval(body.car(), ext, thread);
3260: body = body.cdr();
3261: }
3262: thread.setDynamicEnvironment(oldDynEnv);
3263: return result;
3264: }
3265: };
3266:
3267: // ### multiple-value-prog1
3268: private static final SpecialOperator MULTIPLE_VALUE_PROG1 = new SpecialOperator(
3269: "multiple-value-prog1") {
3270: public LispObject execute(LispObject args, Environment env)
3271: throws ConditionThrowable {
3272: if (args.length() == 0)
3273: throw new ConditionThrowable(
3274: new WrongNumberOfArgumentsException(this ));
3275: final LispThread thread = LispThread.currentThread();
3276: LispObject result = eval(args.car(), env, thread);
3277: LispObject[] values = thread.getValues();
3278: while ((args = args.cdr()) != NIL)
3279: eval(args.car(), env, thread);
3280: thread.setValues(values);
3281: return result;
3282: }
3283: };
3284:
3285: // ### multiple-value-call
3286: private static final SpecialOperator MULTIPLE_VALUE_CALL = new SpecialOperator(
3287: "multiple-value-call") {
3288: public LispObject execute(LispObject args, Environment env)
3289: throws ConditionThrowable {
3290: if (args.length() == 0)
3291: throw new ConditionThrowable(
3292: new WrongNumberOfArgumentsException(this ));
3293: final LispThread thread = LispThread.currentThread();
3294: LispObject function;
3295: LispObject obj = eval(args.car(), env, thread);
3296: args = args.cdr();
3297: if (obj instanceof Symbol) {
3298: function = obj.getSymbolFunction();
3299: if (function == null)
3300: throw new ConditionThrowable(new UndefinedFunction(
3301: obj));
3302: } else if (obj instanceof Function) {
3303: function = obj;
3304: } else
3305: throw new ConditionThrowable(new LispError(String
3306: .valueOf(obj)
3307: + " is not a function name"));
3308: ArrayList arrayList = new ArrayList();
3309: while (args != NIL) {
3310: LispObject form = args.car();
3311: LispObject result = eval(form, env, thread);
3312: LispObject[] values = thread.getValues();
3313: if (values != null) {
3314: for (int i = 0; i < values.length; i++)
3315: arrayList.add(values[i]);
3316: } else
3317: arrayList.add(result);
3318: args = args.cdr();
3319: }
3320: LispObject[] argv = new LispObject[arrayList.size()];
3321: arrayList.toArray(argv);
3322: return funcall(function, argv, thread);
3323: }
3324: };
3325:
3326: // ### and
3327: // Should be a macro.
3328: private static final SpecialOperator AND = new SpecialOperator(
3329: "and") {
3330: public LispObject execute(LispObject args, Environment env)
3331: throws ConditionThrowable {
3332: final LispThread thread = LispThread.currentThread();
3333: LispObject result = T;
3334: while (args != NIL) {
3335: result = eval(args.car(), env, thread);
3336: if (result == NIL) {
3337: if (args.cdr() != NIL) {
3338: // Not the last form.
3339: thread.clearValues();
3340: }
3341: break;
3342: }
3343: args = args.cdr();
3344: }
3345: return result;
3346: }
3347: };
3348:
3349: // ### or
3350: // Should be a macro.
3351: private static final SpecialOperator OR = new SpecialOperator("or") {
3352: public LispObject execute(LispObject args, Environment env)
3353: throws ConditionThrowable {
3354: final LispThread thread = LispThread.currentThread();
3355: LispObject result = NIL;
3356: while (args != NIL) {
3357: result = eval(args.car(), env, thread);
3358: if (result != NIL) {
3359: if (args.cdr() != NIL) {
3360: // Not the last form.
3361: thread.clearValues();
3362: }
3363: break;
3364: }
3365: args = args.cdr();
3366: }
3367: return result;
3368: }
3369: };
3370:
3371: // ### write-char
3372: // write-char character &optional output-stream => character
3373: private static final Primitive WRITE_CHAR = new Primitive(
3374: "write-char") {
3375: public LispObject execute(LispObject[] args)
3376: throws ConditionThrowable {
3377: if (args.length < 1 || args.length > 2)
3378: throw new ConditionThrowable(
3379: new WrongNumberOfArgumentsException(this ));
3380: final char c = LispCharacter.getValue(args[0]);
3381: final CharacterOutputStream out;
3382: if (args.length == 1)
3383: out = checkCharacterOutputStream(_STANDARD_OUTPUT_
3384: .symbolValue());
3385: else
3386: out = outSynonymOf(args[1]);
3387: out.writeChar(c);
3388: return args[0];
3389: }
3390: };
3391:
3392: // ### %write-string
3393: // write-string string output-stream start end => string
3394: private static final Primitive _WRITE_STRING = new Primitive(
3395: "%write-string", PACKAGE_SYS, false) {
3396: public LispObject execute(LispObject[] args)
3397: throws ConditionThrowable {
3398: if (args.length != 4)
3399: throw new ConditionThrowable(
3400: new WrongNumberOfArgumentsException(this ));
3401: String s = LispString.getValue(args[0]);
3402: CharacterOutputStream out = outSynonymOf(args[1]);
3403: int start = Fixnum.getValue(args[2]);
3404: int end = Fixnum.getValue(args[3]);
3405: out.writeString(s.substring(start, end));
3406: return args[0];
3407: }
3408: };
3409:
3410: // ### %write-newline
3411: // %write-newline output-stream => nil
3412: private static final Primitive1 _WRITE_NEWLINE = new Primitive1(
3413: "%write-newline", PACKAGE_SYS, false) {
3414: public LispObject execute(LispObject arg)
3415: throws ConditionThrowable {
3416: outSynonymOf(arg).writeString(
3417: System.getProperty("line.separator"));
3418: return NIL;
3419: }
3420: };
3421:
3422: // ### finish-output
3423: // finish-output &optional output-stream => nil
3424: private static final Primitive FINISH_OUTPUT = new Primitive(
3425: "finish-output") {
3426: public LispObject execute(LispObject[] args)
3427: throws ConditionThrowable {
3428: if (args.length > 1)
3429: throw new ConditionThrowable(
3430: new WrongNumberOfArgumentsException(this ));
3431: return flushOutput(args);
3432: }
3433: };
3434:
3435: // ### force-output
3436: // force-output &optional output-stream => nil
3437: private static final Primitive FORCE_OUTPUT = new Primitive(
3438: "force-output") {
3439: public LispObject execute(LispObject[] args)
3440: throws ConditionThrowable {
3441: if (args.length > 1)
3442: throw new ConditionThrowable(
3443: new WrongNumberOfArgumentsException(this ));
3444: return flushOutput(args);
3445: }
3446: };
3447:
3448: private static final LispObject flushOutput(LispObject[] args)
3449: throws ConditionThrowable {
3450: final LispOutputStream out;
3451: if (args.length == 0)
3452: out = checkCharacterOutputStream(_STANDARD_OUTPUT_
3453: .symbolValue());
3454: else if (args[0] instanceof LispOutputStream)
3455: out = (LispOutputStream) args[0];
3456: else if (args[0] instanceof TwoWayStream)
3457: out = ((TwoWayStream) args[0]).getOutputStream();
3458: else
3459: throw new ConditionThrowable(new TypeError(args[0],
3460: "output stream"));
3461: out.flushOutput();
3462: return NIL;
3463: }
3464:
3465: // ### clear-input
3466: // clear-input &optional input-stream => nil
3467: private static final Primitive CLEAR_INPUT = new Primitive(
3468: "clear-input") {
3469: public LispObject execute(LispObject[] args)
3470: throws ConditionThrowable {
3471: if (args.length > 1)
3472: throw new ConditionThrowable(
3473: new WrongNumberOfArgumentsException(this ));
3474: final CharacterInputStream in;
3475: if (args.length == 0)
3476: in = checkCharacterInputStream(_STANDARD_INPUT_
3477: .symbolValue());
3478: else
3479: in = inSynonymOf(args[0]);
3480: in.clearInput();
3481: return NIL;
3482: }
3483: };
3484:
3485: // ### close
3486: // close stream &key abort => result
3487: private static final Primitive CLOSE = new Primitive("close") {
3488: public LispObject execute(LispObject[] args)
3489: throws ConditionThrowable {
3490: final int length = args.length;
3491: if (length == 0)
3492: throw new ConditionThrowable(
3493: new WrongNumberOfArgumentsException(this ));
3494: LispObject abort = NIL; // Default.
3495: LispStream stream = checkStream(args[0]);
3496: if (length > 1) {
3497: if ((length - 1) % 2 != 0)
3498: throw new ConditionThrowable(new ProgramError(
3499: "odd number of keyword arguments"));
3500: if (length > 3)
3501: throw new ConditionThrowable(
3502: new WrongNumberOfArgumentsException(this ));
3503: if (args[1] == Keyword.ABORT)
3504: abort = args[2];
3505: else
3506: throw new ConditionThrowable(new LispError(
3507: "CLOSE: unrecognized keyword argument: "
3508: + args[1]));
3509: }
3510: return stream.close(abort);
3511: }
3512: };
3513:
3514: // ### multiple-value-list
3515: // multiple-value-list form => list
3516: // Evaluates form and creates a list of the multiple values it returns.
3517: // Should be a macro.
3518: private static final SpecialOperator MULTIPLE_VALUE_LIST = new SpecialOperator(
3519: "multiple-value-list") {
3520: public LispObject execute(LispObject args, Environment env)
3521: throws ConditionThrowable {
3522: if (args.length() != 1)
3523: throw new ConditionThrowable(
3524: new WrongNumberOfArgumentsException(this ));
3525: final LispThread thread = LispThread.currentThread();
3526: LispObject result = eval(args.car(), env, thread);
3527: LispObject[] values = thread.getValues();
3528: thread.clearValues();
3529: if (values == null)
3530: return new Cons(result);
3531: LispObject list = NIL;
3532: for (int i = values.length; i-- > 0;)
3533: list = new Cons(values[i], list);
3534: return list;
3535: }
3536: };
3537:
3538: // ### nth-value
3539: // nth-value n form => object
3540: // Evaluates n and then form and returns the nth value returned by form, or
3541: // NIL if n >= number of values returned.
3542: // Should be a macro.
3543: private static final SpecialOperator NTH_VALUE = new SpecialOperator(
3544: "nth-value") {
3545: public LispObject execute(LispObject args, Environment env)
3546: throws ConditionThrowable {
3547: if (args.length() != 2)
3548: throw new ConditionThrowable(
3549: new WrongNumberOfArgumentsException(this ));
3550: final LispThread thread = LispThread.currentThread();
3551: int n = Fixnum.getInt(eval(args.car(), env, thread));
3552: if (n < 0)
3553: n = 0;
3554: LispObject result = eval(args.cadr(), env, thread);
3555: LispObject[] values = thread.getValues();
3556: thread.clearValues();
3557: if (values == null) {
3558: // A single value was returned.
3559: return n == 0 ? result : NIL;
3560: }
3561: if (n < values.length)
3562: return values[n];
3563: return NIL;
3564: }
3565: };
3566:
3567: // ### write-byte
3568: // write-byte byte stream => byte
3569: private static final Primitive2 WRITE_BYTE = new Primitive2(
3570: "write-byte") {
3571: public LispObject execute(LispObject first, LispObject second)
3572: throws ConditionThrowable {
3573: int n = Fixnum.getValue(first);
3574: if (n < 0 || n > 255)
3575: throw new ConditionThrowable(new TypeError(first,
3576: "unsigned byte"));
3577: final BinaryOutputStream out = checkBinaryOutputStream(second);
3578: out.writeByte(n);
3579: return first;
3580: }
3581: };
3582:
3583: // ### read-byte
3584: // read-byte stream &optional eof-error-p eof-value => byte
3585: private static final Primitive READ_BYTE = new Primitive(
3586: "read-byte") {
3587: public LispObject execute(LispObject[] args)
3588: throws ConditionThrowable {
3589: int length = args.length;
3590: if (length < 1 || length > 3)
3591: throw new ConditionThrowable(
3592: new WrongNumberOfArgumentsException(this ));
3593: final BinaryInputStream in = checkBinaryInputStream(args[0]);
3594: boolean eofError = length > 1 ? (args[1] != NIL) : true;
3595: LispObject eofValue = length > 2 ? args[2] : NIL;
3596: return in.readByte(eofError, eofValue);
3597: }
3598: };
3599:
3600: // ### read-line
3601: // read-line &optional input-stream eof-error-p eof-value recursive-p
3602: // => line, missing-newline-p
3603: private static final Primitive READ_LINE = new Primitive(
3604: "read-line") {
3605: public LispObject execute(LispObject[] args)
3606: throws ConditionThrowable {
3607: int length = args.length;
3608: if (length > 4)
3609: throw new ConditionThrowable(
3610: new WrongNumberOfArgumentsException(this ));
3611: CharacterInputStream stream = null;
3612: if (length == 0)
3613: stream = getStandardInput();
3614: else if (args[0] instanceof CharacterInputStream)
3615: stream = (CharacterInputStream) args[0];
3616: else if (args[0] instanceof TwoWayStream) {
3617: LispInputStream in = ((TwoWayStream) args[0])
3618: .getInputStream();
3619: if (in instanceof CharacterInputStream)
3620: stream = (CharacterInputStream) in;
3621: }
3622: if (stream == null)
3623: throw new ConditionThrowable(new TypeError(args[0],
3624: "character input stream"));
3625: boolean eofError = length > 1 ? (args[1] != NIL) : true;
3626: LispObject eofValue = length > 2 ? args[2] : NIL;
3627: boolean recursive = length > 3 ? (args[3] != NIL) : false;
3628: return stream.readLine(eofError, eofValue);
3629: }
3630: };
3631:
3632: // ### %read-from-string
3633: // read-from-string string &optional eof-error-p eof-value &key start end
3634: // preserve-whitespace => object, position
3635: private static final Primitive _READ_FROM_STRING = new Primitive(
3636: "%read-from-string", PACKAGE_SYS, false) {
3637: public LispObject execute(LispObject[] args)
3638: throws ConditionThrowable {
3639: if (args.length < 6)
3640: throw new ConditionThrowable(
3641: new WrongNumberOfArgumentsException(this ));
3642: String s = LispString.getValue(args[0]);
3643: boolean eofError = args[1] != NIL;
3644: LispObject eofValue = args[2];
3645: LispObject start = args[3];
3646: LispObject end = args[4];
3647: boolean preserveWhitespace = args[5] != NIL;
3648: int startIndex, endIndex;
3649: if (start != NIL)
3650: startIndex = (int) Fixnum.getValue(start);
3651: else
3652: startIndex = 0;
3653: if (end != NIL)
3654: endIndex = (int) Fixnum.getValue(end);
3655: else
3656: endIndex = s.length();
3657: StringInputStream in = new StringInputStream(s, startIndex,
3658: endIndex);
3659: LispObject result;
3660: if (preserveWhitespace)
3661: result = in.readPreservingWhitespace(eofError,
3662: eofValue, false);
3663: else
3664: result = in.read(eofError, eofValue, false);
3665: LispObject[] values = new LispObject[2];
3666: values[0] = result;
3667: values[1] = new Fixnum(in.getOffset());
3668: LispThread.currentThread().setValues(values);
3669: return result;
3670: }
3671: };
3672:
3673: private static final Primitive1 STANDARD_CHAR_P = new Primitive1(
3674: "standard-char-p") {
3675: public LispObject execute(LispObject arg)
3676: throws ConditionThrowable {
3677: return checkCharacter(arg).isStandardChar();
3678: }
3679: };
3680:
3681: private static final Primitive1 GRAPHIC_CHAR_P = new Primitive1(
3682: "graphic-char-p") {
3683: public LispObject execute(LispObject arg)
3684: throws ConditionThrowable {
3685: char c = LispCharacter.getValue(arg);
3686: return (c >= ' ' && c < 127) ? T : NIL;
3687: }
3688: };
3689:
3690: private static final Primitive1 ALPHA_CHAR_P = new Primitive1(
3691: "alpha-char-p") {
3692: public LispObject execute(LispObject arg)
3693: throws ConditionThrowable {
3694: char c = LispCharacter.getValue(arg);
3695: return Character.isLetter(c) ? T : NIL;
3696: }
3697: };
3698:
3699: private static final Primitive1 NAME_CHAR = new Primitive1(
3700: "name-char") {
3701: public LispObject execute(LispObject arg)
3702: throws ConditionThrowable {
3703: String s = LispString.getValue(string(arg));
3704: int n = nameToChar(s);
3705: return n >= 0 ? LispCharacter.getInstance((char) n) : NIL;
3706: }
3707: };
3708:
3709: private static final Primitive1 CHAR_NAME = new Primitive1(
3710: "char-name") {
3711: public LispObject execute(LispObject arg)
3712: throws ConditionThrowable {
3713: char c = LispCharacter.getValue(arg);
3714: String name = null;
3715: switch (c) {
3716: case ' ':
3717: name = "Space";
3718: break;
3719: case '\n':
3720: name = "Newline";
3721: break;
3722: case '\t':
3723: name = "Tab";
3724: break;
3725: case '\r':
3726: name = "Return";
3727: break;
3728: case '\f':
3729: name = "Page";
3730: break;
3731: case '\b':
3732: name = "Backspace";
3733: break;
3734: default:
3735: break;
3736: }
3737: return name != null ? new LispString(name) : NIL;
3738: }
3739: };
3740:
3741: private static final Primitive DIGIT_CHAR = new Primitive(
3742: "digit-char") {
3743: public LispObject execute(LispObject[] args)
3744: throws ConditionThrowable {
3745: final long radix;
3746: switch (args.length) {
3747: case 1:
3748: radix = 10;
3749: break;
3750: case 2:
3751: radix = Fixnum.getValue(args[1]);
3752: break;
3753: default:
3754: throw new ConditionThrowable(
3755: new WrongNumberOfArgumentsException(this ));
3756: }
3757: long weight = Fixnum.getValue(args[0]);
3758: if (weight >= radix || weight >= 36)
3759: return NIL;
3760: if (weight < 10)
3761: return LispCharacter.getInstance((char) ('0' + weight));
3762: return LispCharacter
3763: .getInstance((char) ('A' + weight - 10));
3764: }
3765: };
3766:
3767: private static final Primitive1 _CALL_COUNT = new Primitive1(
3768: "%call-count", PACKAGE_SYS, false) {
3769: public LispObject execute(LispObject arg)
3770: throws ConditionThrowable {
3771: return new Fixnum(arg.getCallCount());
3772: }
3773: };
3774:
3775: private static final Primitive2 _SET_CALL_COUNT = new Primitive2(
3776: "%set-call-count", PACKAGE_SYS, false) {
3777: public LispObject execute(LispObject first, LispObject second)
3778: throws ConditionThrowable {
3779: first.setCallCount(Fixnum.getValue(second));
3780: return second;
3781: }
3782: };
3783:
3784: // ### get-dispatch-macro-character
3785: // get-dispatch-macro-character disp-char sub-char &optional readtable
3786: // => function
3787: private static final Primitive GET_DISPATCH_MACRO_CHARACTER = new Primitive(
3788: "get-dispatch-macro-character") {
3789: public LispObject execute(LispObject[] args)
3790: throws ConditionThrowable {
3791: if (args.length < 2 || args.length > 3)
3792: throw new ConditionThrowable(
3793: new WrongNumberOfArgumentsException(this ));
3794: char dispChar = LispCharacter.getValue(args[0]);
3795: char subChar = LispCharacter.getValue(args[1]);
3796: Readtable readtable;
3797: if (args.length == 3)
3798: readtable = checkReadtable(args[2]);
3799: else
3800: readtable = getCurrentReadtable();
3801: return readtable.getDispatchMacroCharacter(dispChar,
3802: subChar);
3803: }
3804: };
3805:
3806: // ### set-dispatch-macro-character
3807: // set-dispatch-macro-character disp-char sub-char new-function &optional readtable
3808: // => t
3809: private static final Primitive SET_DISPATCH_MACRO_CHARACTER = new Primitive(
3810: "set-dispatch-macro-character") {
3811: public LispObject execute(LispObject[] args)
3812: throws ConditionThrowable {
3813: if (args.length < 3 || args.length > 4)
3814: throw new ConditionThrowable(
3815: new WrongNumberOfArgumentsException(this ));
3816: char dispChar = LispCharacter.getValue(args[0]);
3817: char subChar = LispCharacter.getValue(args[1]);
3818: LispObject function = args[2];
3819: Readtable readtable;
3820: if (args.length == 4)
3821: readtable = checkReadtable(args[3]);
3822: else
3823: readtable = getCurrentReadtable();
3824: return readtable.setDispatchMacroCharacter(dispChar,
3825: subChar, function);
3826: }
3827: };
3828:
3829: // ### read
3830: // read &optional input-stream eof-error-p eof-value recursive-p => object
3831: private static final Primitive READ = new Primitive("read") {
3832: public LispObject execute(LispObject[] args)
3833: throws ConditionThrowable {
3834: int length = args.length;
3835: if (length > 4)
3836: throw new ConditionThrowable(
3837: new WrongNumberOfArgumentsException(this ));
3838: CharacterInputStream stream = length > 0 ? checkCharacterInputStream(args[0])
3839: : getStandardInput();
3840: boolean eofError = length > 1 ? (args[1] != NIL) : true;
3841: LispObject eofValue = length > 2 ? args[2] : NIL;
3842: boolean recursive = length > 3 ? (args[3] != NIL) : false;
3843: return stream.read(eofError, eofValue, recursive);
3844: }
3845: };
3846:
3847: // ### read-char
3848: // read-char &optional input-stream eof-error-p eof-value recursive-p => char
3849: private static final Primitive READ_CHAR = new Primitive(
3850: "read-char") {
3851: public LispObject execute(LispObject[] args)
3852: throws ConditionThrowable {
3853: int length = args.length;
3854: if (length > 4)
3855: throw new ConditionThrowable(
3856: new WrongNumberOfArgumentsException(this ));
3857: CharacterInputStream stream = length > 0 ? checkCharacterInputStream(args[0])
3858: : getStandardInput();
3859: boolean eofError = length > 1 ? (args[1] != NIL) : true;
3860: LispObject eofValue = length > 2 ? args[2] : NIL;
3861: boolean recursive = length > 3 ? (args[3] != NIL) : false;
3862: return stream.readChar(eofError, eofValue);
3863: }
3864: };
3865:
3866: // ### unread-char
3867: // unread-char character &optional input-stream => nil
3868: private static final Primitive UNREAD_CHAR = new Primitive(
3869: "unread-char") {
3870: public LispObject execute(LispObject[] args)
3871: throws ConditionThrowable {
3872: int length = args.length;
3873: if (length < 1)
3874: throw new ConditionThrowable(
3875: new WrongNumberOfArgumentsException(this ));
3876: CharacterInputStream stream = length > 1 ? checkCharacterInputStream(args[1])
3877: : getStandardInput();
3878: return stream.unreadChar(checkCharacter(args[0]));
3879: }
3880: };
3881:
3882: private static final Primitive2 _SET_LAMBDA_NAME = new Primitive2(
3883: "%set-lambda-name", PACKAGE_SYS, false) {
3884: public LispObject execute(LispObject first, LispObject second)
3885: throws ConditionThrowable {
3886: if (first instanceof Function) {
3887: Function f = (Function) first;
3888: f.setLambdaName(second);
3889: return second;
3890: } else
3891: throw new ConditionThrowable(new TypeError(first,
3892: "function"));
3893: }
3894: };
3895:
3896: // Destructively alters the vector, changing its length to NEW-SIZE, which
3897: // must be less than or equal to its current length.
3898: // shrink-vector vector new-size => vector
3899: private static final Primitive2 SHRINK_VECTOR = new Primitive2(
3900: "shrink-vector", PACKAGE_SYS, false) {
3901: public LispObject execute(LispObject first, LispObject second)
3902: throws ConditionThrowable {
3903: checkVector(first).shrink(Fixnum.getInt(second));
3904: return first;
3905: }
3906: };
3907:
3908: // ### vector-subseq
3909: // vector-subseq vector start &optional end => subsequence
3910: private static final Primitive3 VECTOR_SUBSEQ = new Primitive3(
3911: "vector-subseq", PACKAGE_SYS, false) {
3912: public LispObject execute(LispObject first, LispObject second,
3913: LispObject third) throws ConditionThrowable {
3914: AbstractVector v = checkVector(first);
3915: int start = Fixnum.getValue(second);
3916: int end = third != NIL ? Fixnum.getValue(third) : v
3917: .length();
3918: if (start > end) {
3919: StringBuffer sb = new StringBuffer("start (");
3920: sb.append(start);
3921: sb.append(") is greater than end (");
3922: sb.append(end);
3923: sb.append(')');
3924: throw new ConditionThrowable(new TypeError(sb
3925: .toString()));
3926: }
3927: return v.subseq(start, end);
3928: }
3929: };
3930:
3931: // ### random
3932: // random limit &optional random-state => random-number
3933: private static final Primitive RANDOM = new Primitive("random") {
3934: public LispObject execute(LispObject[] args)
3935: throws ConditionThrowable {
3936: int length = args.length;
3937: if (length < 1 || length > 2)
3938: throw new ConditionThrowable(
3939: new WrongNumberOfArgumentsException(this ));
3940: Random random;
3941: if (length == 2)
3942: random = (Random) JavaObject.getObject(args[1]);
3943: else
3944: random = (Random) JavaObject.getObject(_RANDOM_STATE_
3945: .symbolValueNoThrow());
3946: if (args[0] instanceof Fixnum) {
3947: int limit = ((Fixnum) args[0]).getValue();
3948: if (limit > 0) {
3949: int n = random.nextInt((int) limit);
3950: return new Fixnum(n);
3951: }
3952: } else if (args[0] instanceof Bignum) {
3953: BigInteger limit = ((Bignum) args[0]).getValue();
3954: if (limit.signum() > 0) {
3955: int bitLength = limit.bitLength();
3956: BigInteger rand = new BigInteger(bitLength + 1,
3957: random);
3958: BigInteger remainder = rand.remainder(limit);
3959: return number(remainder);
3960: }
3961: } else if (args[0] instanceof LispFloat) {
3962: double limit = ((LispFloat) args[0]).getValue();
3963: if (limit > 0) {
3964: double rand = random.nextDouble();
3965: return new LispFloat(rand * limit);
3966: }
3967: }
3968: throw new ConditionThrowable(new TypeError(args[0],
3969: "positive integer or positive float"));
3970: }
3971: };
3972:
3973: // ### make-random-state
3974: private static final Primitive MAKE_RANDOM_STATE = new Primitive(
3975: "make-random-state") {
3976: public LispObject execute(LispObject[] args)
3977: throws ConditionThrowable {
3978: // FIXME Ignore arguments (or lack thereof).
3979: return new JavaObject(new Random());
3980: }
3981: };
3982:
3983: // ### truncate
3984: private static final Primitive TRUNCATE = new Primitive("truncate") {
3985: public LispObject execute(LispObject[] args)
3986: throws ConditionThrowable {
3987: final int length = args.length;
3988: if (length < 1 || length > 2)
3989: throw new ConditionThrowable(
3990: new WrongNumberOfArgumentsException(this ));
3991: LispObject n = args[0];
3992: LispObject d = length == 1 ? Fixnum.ONE : args[1];
3993: if (n instanceof Fixnum)
3994: return ((Fixnum) n).truncate(d);
3995: if (n instanceof Bignum)
3996: return ((Bignum) n).truncate(d);
3997: if (n instanceof Ratio)
3998: return ((Ratio) n).truncate(d);
3999: if (n instanceof LispFloat)
4000: return ((LispFloat) n).truncate(d);
4001: throw new ConditionThrowable(new TypeError(n, "number"));
4002: }
4003: };
4004:
4005: // ### expt
4006: // expt base-number power-number => result
4007: public static final Primitive2 EXPT = new Primitive2("expt") {
4008: public LispObject execute(LispObject n, LispObject power)
4009: throws ConditionThrowable {
4010: if (power.zerop()) {
4011: if (power instanceof Fixnum) {
4012: if (n instanceof LispFloat)
4013: return LispFloat.ONE;
4014: if (n instanceof Complex) {
4015: if (((Complex) n).getRealPart() instanceof LispFloat)
4016: return Complex.getInstance(LispFloat.ONE,
4017: LispFloat.ZERO);
4018: }
4019: return Fixnum.ONE;
4020: }
4021: if (power instanceof LispFloat) {
4022: return LispFloat.ONE;
4023: }
4024: }
4025: if (power instanceof Fixnum) {
4026: LispObject result = null;
4027: if (n instanceof LispFloat)
4028: result = LispFloat.ONE;
4029: else
4030: result = Fixnum.ONE;
4031: int count = ((Fixnum) power).getValue();
4032: if (count > 0) {
4033: for (int i = count; i-- > 0;)
4034: result = result.multiplyBy(n);
4035: } else if (count < 0) {
4036: for (int i = -count; i-- > 0;)
4037: result = result.divideBy(n);
4038: }
4039: return result;
4040: }
4041: if (power instanceof LispFloat) {
4042: if (n instanceof Fixnum) {
4043: double d = Math.pow(((Fixnum) n).getValue(),
4044: ((LispFloat) power).getValue());
4045: return new LispFloat(d);
4046: }
4047: }
4048: throw new ConditionThrowable(new LispError(
4049: "EXPT: unsupported case"));
4050: }
4051: };
4052:
4053: // ### list
4054: private static final Primitive LIST = new Primitive("list") {
4055: public LispObject execute(LispObject arg)
4056: throws ConditionThrowable {
4057: return new Cons(arg);
4058: }
4059:
4060: public LispObject execute(LispObject first, LispObject second)
4061: throws ConditionThrowable {
4062: return new Cons(first, new Cons(second));
4063: }
4064:
4065: public LispObject execute(LispObject first, LispObject second,
4066: LispObject third) throws ConditionThrowable {
4067: return new Cons(first, new Cons(second, new Cons(third)));
4068: }
4069:
4070: public LispObject execute(LispObject[] args)
4071: throws ConditionThrowable {
4072: LispObject result = NIL;
4073: for (int i = args.length; i-- > 0;)
4074: result = new Cons(args[i], result);
4075: return result;
4076: }
4077: };
4078:
4079: // ### list*
4080: private static final Primitive LIST_ = new Primitive("list*") {
4081: public LispObject execute() throws ConditionThrowable {
4082: throw new ConditionThrowable(
4083: new WrongNumberOfArgumentsException("LIST*"));
4084: }
4085:
4086: public LispObject execute(LispObject arg)
4087: throws ConditionThrowable {
4088: return arg;
4089: }
4090:
4091: public LispObject execute(LispObject first, LispObject second)
4092: throws ConditionThrowable {
4093: return new Cons(first, second);
4094: }
4095:
4096: public LispObject execute(LispObject first, LispObject second,
4097: LispObject third) throws ConditionThrowable {
4098: return new Cons(first, new Cons(second, third));
4099: }
4100:
4101: public LispObject execute(LispObject[] args)
4102: throws ConditionThrowable {
4103: int i = args.length - 1;
4104: LispObject result = args[i];
4105: while (i-- > 0)
4106: result = new Cons(args[i], result);
4107: return result;
4108: }
4109: };
4110:
4111: // ### nreverse
4112: public static final Primitive1 NREVERSE = new Primitive1("nreverse") {
4113: public LispObject execute(LispObject arg)
4114: throws ConditionThrowable {
4115: return arg.nreverse();
4116: }
4117: };
4118:
4119: // ### nreconc
4120: // From CLISP.
4121: private static final Primitive2 NRECONC = new Primitive2("nreconc") {
4122: public LispObject execute(LispObject list, LispObject obj)
4123: throws ConditionThrowable {
4124: if (list instanceof Cons) {
4125: LispObject list3 = list.cdr();
4126: if (list3 instanceof Cons) {
4127: if (list3.cdr() instanceof Cons) {
4128: LispObject list1 = list3;
4129: LispObject list2 = NIL;
4130: do {
4131: LispObject h = list3.cdr();
4132: list3.setCdr(list2);
4133: list2 = list3;
4134: list3 = h;
4135: } while (list3.cdr() instanceof Cons);
4136: list.setCdr(list2);
4137: list1.setCdr(list3);
4138: }
4139: LispObject h = list.car();
4140: list.setCar(list3.car());
4141: list3.setCar(h);
4142: list3.setCdr(obj);
4143: } else {
4144: list.setCdr(obj);
4145: }
4146: return list;
4147: } else
4148: return obj;
4149: }
4150: };
4151:
4152: // ### reverse
4153: private static final Primitive1 REVERSE = new Primitive1("reverse") {
4154: public LispObject execute(LispObject arg)
4155: throws ConditionThrowable {
4156: if (arg instanceof AbstractVector)
4157: return ((AbstractVector) arg).reverse();
4158: if (arg instanceof Cons) {
4159: LispObject result = NIL;
4160: while (arg != NIL) {
4161: result = new Cons(arg.car(), result);
4162: arg = arg.cdr();
4163: }
4164: return result;
4165: }
4166: if (arg == NIL)
4167: return NIL;
4168: throw new ConditionThrowable(new TypeError(arg,
4169: "proper sequence"));
4170: }
4171: };
4172:
4173: // ### %set-elt
4174: // %setelt sequence index newval => newval
4175: private static final Primitive3 _SET_ELT = new Primitive3(
4176: "%set-elt", PACKAGE_SYS, false) {
4177: public LispObject execute(LispObject first, LispObject second,
4178: LispObject third) throws ConditionThrowable {
4179: if (first instanceof AbstractVector) {
4180: ((AbstractVector) first).set(Fixnum.getValue(second),
4181: third);
4182: return third;
4183: }
4184: if (first instanceof Cons) {
4185: int index = Fixnum.getValue(second);
4186: if (index < 0)
4187: throw new ConditionThrowable(new TypeError());
4188: LispObject list = first;
4189: int i = 0;
4190: while (true) {
4191: if (i == index) {
4192: list.setCar(third);
4193: return third;
4194: }
4195: list = list.cdr();
4196: if (list == NIL)
4197: throw new ConditionThrowable(new TypeError());
4198: ++i;
4199: }
4200: }
4201: throw new ConditionThrowable(new TypeError(first,
4202: "sequence"));
4203: }
4204: };
4205:
4206: // (defun maptree (fun x)
4207: // (if (atom x)
4208: // (funcall fun x)
4209: // (let ((a (funcall fun (car x)))
4210: // (d (maptree fun (cdr x))))
4211: // (if (and (eql a (car x)) (eql d (cdr x)))
4212: // x
4213: // (cons a d)))))
4214:
4215: // ### maptree
4216: private static final Primitive2 MAPTREE = new Primitive2("maptree",
4217: PACKAGE_SYS, false) {
4218: public LispObject execute(LispObject fun, LispObject x)
4219: throws ConditionThrowable {
4220: if (x instanceof Cons) {
4221: LispObject a = fun.execute(x.car());
4222: // Recurse!
4223: LispObject d = execute(fun, x.cdr());
4224: if (a.eql(x.car()) && d.eql(x.cdr()))
4225: return x;
4226: else
4227: return new Cons(a, d);
4228: } else
4229: return fun.execute(x);
4230: }
4231: };
4232:
4233: // ### %make-list
4234: private static final Primitive2 _MAKE_LIST = new Primitive2(
4235: "%make-list", PACKAGE_SYS, false) {
4236: public LispObject execute(LispObject first, LispObject second)
4237: throws ConditionThrowable {
4238: int size = Fixnum.getValue(first);
4239: if (size < 0)
4240: throw new ConditionThrowable(new TypeError(
4241: "MAKE-LIST: " + size
4242: + " is not a valid list length"));
4243: LispObject result = NIL;
4244: for (int i = size; i-- > 0;)
4245: result = new Cons(second, result);
4246: return result;
4247: }
4248: };
4249:
4250: // %member item list key test test-not => tail
4251: private static final Primitive _MEMBER = new Primitive("%member",
4252: PACKAGE_SYS, false) {
4253: public LispObject execute(LispObject[] args)
4254: throws ConditionThrowable {
4255: if (args.length != 5)
4256: throw new ConditionThrowable(
4257: new WrongNumberOfArgumentsException(this ));
4258: LispObject item = args[0];
4259: LispObject tail = checkList(args[1]);
4260: LispObject key = args[2];
4261: if (key != NIL) {
4262: if (key instanceof Symbol)
4263: key = key.getSymbolFunction();
4264: if (!(key instanceof Function))
4265: throw new ConditionThrowable(new UndefinedFunction(
4266: args[2]));
4267: }
4268: LispObject test = args[3];
4269: LispObject testNot = args[4];
4270: if (test != NIL && testNot != NIL)
4271: throw new ConditionThrowable(new LispError(
4272: "MEMBER: test and test-not both supplied"));
4273: if (test == NIL && testNot == NIL) {
4274: test = EQL;
4275: } else if (test != NIL) {
4276: if (test instanceof Symbol)
4277: test = test.getSymbolFunction();
4278: if (!(test instanceof Function))
4279: throw new ConditionThrowable(new UndefinedFunction(
4280: args[3]));
4281: } else if (testNot != NIL) {
4282: if (testNot instanceof Symbol)
4283: testNot = testNot.getSymbolFunction();
4284: if (!(testNot instanceof Function))
4285: throw new ConditionThrowable(new UndefinedFunction(
4286: args[3]));
4287: }
4288: if (key == NIL && test == EQL) {
4289: while (tail != NIL) {
4290: if (item.eql(tail.car()))
4291: return tail;
4292: tail = tail.cdr();
4293: }
4294: return NIL;
4295: }
4296: while (tail != NIL) {
4297: LispObject candidate = tail.car();
4298: if (key != NIL)
4299: candidate = key.execute(candidate);
4300: if (test != NIL) {
4301: if (test.execute(item, candidate) == T)
4302: return tail;
4303: } else if (testNot != NIL) {
4304: if (testNot.execute(item, candidate) == NIL)
4305: return tail;
4306: }
4307: tail = tail.cdr();
4308: }
4309: return NIL;
4310: }
4311: };
4312:
4313: // ### funcall-key
4314: // funcall-key function-or-nil element
4315: private static final Primitive2 FUNCALL_KEY = new Primitive2(
4316: "funcall-key", PACKAGE_SYS, false) {
4317: public LispObject execute(LispObject first, LispObject second)
4318: throws ConditionThrowable {
4319: if (first != NIL)
4320: return funcall1(first, second, LispThread
4321: .currentThread());
4322: return second;
4323: }
4324: };
4325:
4326: // ### coerce-to-function
4327: private static final Primitive1 COERCE_TO_FUNCTION = new Primitive1(
4328: "coerce-to-function", PACKAGE_SYS, false) {
4329: public LispObject execute(LispObject arg)
4330: throws ConditionThrowable {
4331: return coerceToFunction(arg);
4332: }
4333: };
4334:
4335: // ### arglist
4336: private static final Primitive1 ARGLIST = new Primitive1("arglist",
4337: PACKAGE_SYS, false) {
4338: public LispObject execute(LispObject arg)
4339: throws ConditionThrowable {
4340: Function function = coerceToFunction(arg);
4341: LispObject arglist = function.getArglist();
4342: LispObject[] values = new LispObject[2];
4343: if (arglist != null) {
4344: values[0] = arglist;
4345: values[1] = T;
4346: } else {
4347: values[0] = NIL;
4348: values[1] = NIL;
4349: }
4350: LispThread.currentThread().setValues(values);
4351: return values[0];
4352: }
4353: };
4354:
4355: private static final Primitive2 _SET_ARGLIST = new Primitive2(
4356: "%set-arglist", PACKAGE_SYS, false) {
4357: public LispObject execute(LispObject first, LispObject second)
4358: throws ConditionThrowable {
4359: coerceToFunction(first).setArglist(second);
4360: return second;
4361: }
4362: };
4363:
4364: // ### streamp
4365: private static final Primitive1 STREAMP = new Primitive1("streamp") {
4366: public LispObject execute(LispObject arg) {
4367: return arg instanceof LispStream ? T : NIL;
4368: }
4369: };
4370:
4371: // ### integerp
4372: private static final Primitive1 INTEGERP = new Primitive1(
4373: "integerp") {
4374: public LispObject execute(LispObject arg) {
4375: return arg.INTEGERP();
4376: }
4377: };
4378:
4379: // ### realp
4380: private static final Primitive1 REALP = new Primitive1("realp") {
4381: public LispObject execute(LispObject arg) {
4382: return arg.REALP();
4383: }
4384: };
4385:
4386: // ### rationalp
4387: private static final Primitive1 RATIONALP = new Primitive1(
4388: "rationalp") {
4389: public LispObject execute(LispObject arg) {
4390: return arg.RATIONALP();
4391: }
4392: };
4393:
4394: // ### complex
4395: private static final Primitive2 COMPLEX = new Primitive2("complex") {
4396: public LispObject execute(LispObject arg)
4397: throws ConditionThrowable {
4398: if (arg instanceof LispFloat)
4399: return Complex.getInstance(arg, LispFloat.ZERO);
4400: if (arg.realp())
4401: return arg;
4402: throw new ConditionThrowable(new TypeError(arg,
4403: "real number"));
4404: }
4405:
4406: public LispObject execute(LispObject first, LispObject second)
4407: throws ConditionThrowable {
4408: return Complex.getInstance(first, second);
4409: }
4410: };
4411:
4412: // ### complexp
4413: private static final Primitive1 COMPLEXP = new Primitive1(
4414: "complexp") {
4415: public LispObject execute(LispObject arg) {
4416: return arg.COMPLEXP();
4417: }
4418: };
4419:
4420: // ### numerator
4421: private static final Primitive1 NUMERATOR = new Primitive1(
4422: "numerator") {
4423: public LispObject execute(LispObject arg)
4424: throws ConditionThrowable {
4425: return arg.NUMERATOR();
4426: }
4427: };
4428:
4429: // ### denominator
4430: private static final Primitive1 DENOMINATOR = new Primitive1(
4431: "denominator") {
4432: public LispObject execute(LispObject arg)
4433: throws ConditionThrowable {
4434: return arg.DENOMINATOR();
4435: }
4436: };
4437:
4438: // ### realpart
4439: private static final Primitive1 REALPART = new Primitive1(
4440: "realpart") {
4441: public LispObject execute(LispObject arg)
4442: throws ConditionThrowable {
4443: if (arg instanceof Complex)
4444: return ((Complex) arg).getRealPart();
4445: if (arg.numberp())
4446: return arg;
4447: throw new ConditionThrowable(new TypeError(arg, "number"));
4448: }
4449: };
4450:
4451: // ### imagpart
4452: private static final Primitive1 IMAGPART = new Primitive1(
4453: "imagpart") {
4454: public LispObject execute(LispObject arg)
4455: throws ConditionThrowable {
4456: if (arg instanceof Complex)
4457: return ((Complex) arg).getImaginaryPart();
4458: return arg.multiplyBy(Fixnum.ZERO);
4459: }
4460: };
4461:
4462: // ### integer-length
4463: private static final Primitive1 INTEGER_LENGTH = new Primitive1(
4464: "integer-length") {
4465: public LispObject execute(LispObject arg)
4466: throws ConditionThrowable {
4467: BigInteger value;
4468: if (arg instanceof Fixnum)
4469: value = BigInteger.valueOf(((Fixnum) arg).getValue());
4470: else if (arg instanceof Bignum)
4471: value = ((Bignum) arg).getValue();
4472: else
4473: throw new ConditionThrowable(new TypeError(arg,
4474: "integer"));
4475: return new Fixnum(value.bitLength());
4476: }
4477: };
4478:
4479: private static final Primitive1 COS = new Primitive1("cos") {
4480: public LispObject execute(LispObject arg)
4481: throws ConditionThrowable {
4482: return cos(arg);
4483: }
4484: };
4485:
4486: private static LispObject cos(LispObject arg)
4487: throws ConditionThrowable {
4488: if (arg.realp()) {
4489: LispFloat argf = LispFloat.coerceToFloat(arg);
4490: return new LispFloat(Math.cos(argf.getValue()));
4491: } else if (arg instanceof Complex) {
4492: Complex argc = (Complex) arg;
4493: Complex iargc = (Complex) argc.multiplyBy(Complex
4494: .getInstance(new Fixnum(0), new Fixnum(1)));
4495: Complex c = (Complex) exp(iargc);
4496: c = (Complex) c.add(exp(iargc.multiplyBy(new Fixnum(-1))));
4497: c = (Complex) c.divideBy(new Fixnum(2));
4498: return c;
4499: }
4500:
4501: throw new ConditionThrowable(new TypeError(arg, "number"));
4502: }
4503:
4504: private static final Primitive1 SIN = new Primitive1("sin") {
4505: public LispObject execute(LispObject arg)
4506: throws ConditionThrowable {
4507: return sin(arg);
4508: }
4509: };
4510:
4511: private static LispObject sin(LispObject arg)
4512: throws ConditionThrowable {
4513: if (arg.realp()) { // return real
4514: LispFloat argf = LispFloat.coerceToFloat(arg);
4515: return new LispFloat(Math.sin(argf.getValue()));
4516: } else if (arg instanceof Complex) {
4517: Complex argc = (Complex) arg;
4518: Complex iargc = (Complex) argc.multiplyBy(Complex
4519: .getInstance(new Fixnum(0), new Fixnum(1)));
4520: Complex c = (Complex) exp(iargc);
4521: c = (Complex) c.subtract(exp(iargc
4522: .multiplyBy(new Fixnum(-1))));
4523: c = (Complex) c.divideBy((new Fixnum(2)).multiplyBy(Complex
4524: .getInstance(new Fixnum(0), new Fixnum(1))));
4525: return c;
4526: }
4527:
4528: throw new ConditionThrowable(new TypeError(arg, "number"));
4529: }
4530:
4531: private static final Primitive1 TAN = new Primitive1("tan") {
4532: public LispObject execute(LispObject arg)
4533: throws ConditionThrowable {
4534: return tan(arg);
4535: }
4536: };
4537:
4538: private static LispObject tan(LispObject arg)
4539: throws ConditionThrowable {
4540: return sin(arg).divideBy(cos(arg));
4541: }
4542:
4543: private static final Primitive1 EXP = new Primitive1("exp") {
4544: public LispObject execute(LispObject arg)
4545: throws ConditionThrowable {
4546: return exp(arg);
4547: }
4548: };
4549:
4550: private static LispObject exp(LispObject arg)
4551: throws ConditionThrowable {
4552: if (arg.realp()) { // return real
4553: LispFloat argf = LispFloat.coerceToFloat(arg);
4554: return new LispFloat(Math.exp(argf.getValue()));
4555: } else if (arg instanceof Complex) {
4556: Complex argc = (Complex) arg;
4557: double re = LispFloat.coerceToFloat(argc.getRealPart())
4558: .getValue();
4559: double im = LispFloat
4560: .coerceToFloat(argc.getImaginaryPart()).getValue();
4561: LispFloat resX = new LispFloat(Math.exp(re) * Math.cos(im));
4562: LispFloat resY = new LispFloat(Math.exp(re) * Math.sin(im));
4563: return Complex.getInstance(resX, resY);
4564: }
4565:
4566: throw new ConditionThrowable(new TypeError(arg, "number"));
4567: }
4568:
4569: // ### sqrt
4570: private static final Primitive1 SQRT = new Primitive1("sqrt") {
4571: public LispObject execute(LispObject arg)
4572: throws ConditionThrowable {
4573: return sqrt(arg);
4574: }
4575: };
4576:
4577: private static final LispObject sqrt(LispObject obj)
4578: throws ConditionThrowable {
4579: if (obj.realp() && !obj.minusp()) { // returning real
4580: LispFloat f = LispFloat.coerceToFloat(obj);
4581: return new LispFloat(Math.sqrt(f.getValue()));
4582: } else { // returning Complex
4583: if (obj.realp()) {
4584: return Complex.getInstance(new LispFloat(0),
4585: sqrt(Fixnum.ZERO.subtract(obj)));
4586: } else if (obj instanceof Complex) {
4587: return exp(log(obj).divideBy(Fixnum.TWO));
4588: }
4589: }
4590:
4591: throw new ConditionThrowable(new TypeError(obj, "number"));
4592: }
4593:
4594: private static final Primitive LOG = new Primitive("log") {
4595: public LispObject execute(LispObject arg)
4596: throws ConditionThrowable {
4597: return log(arg);
4598: }
4599:
4600: public LispObject execute(LispObject number, LispObject base)
4601: throws ConditionThrowable {
4602: return log(number).divideBy(log(base));
4603: }
4604: };
4605:
4606: private static final LispObject log(LispObject obj)
4607: throws ConditionThrowable {
4608: if (obj.realp() && !obj.minusp()) { // real value
4609: if (obj instanceof Fixnum)
4610: return new LispFloat(Math
4611: .log(((Fixnum) obj).getValue()));
4612: if (obj instanceof Bignum)
4613: return new LispFloat(Math.log(((Bignum) obj)
4614: .floatValue()));
4615: if (obj instanceof Ratio)
4616: return new LispFloat(Math.log(((Ratio) obj)
4617: .floatValue()));
4618: if (obj instanceof LispFloat)
4619: return new LispFloat(Math.log(((LispFloat) obj)
4620: .getValue()));
4621: } else { // returning Complex
4622: LispFloat re, im, phase, abs;
4623: if (obj.realp() && obj.minusp()) {
4624: re = LispFloat.coerceToFloat(obj);
4625: abs = new LispFloat(Math.abs(re.getValue()));
4626: phase = new LispFloat(Math.PI);
4627: return Complex.getInstance(new LispFloat(Math.log(abs
4628: .getValue())), phase);
4629: } else if (obj instanceof Complex) {
4630: re = LispFloat.coerceToFloat(((Complex) obj)
4631: .getRealPart());
4632: im = LispFloat.coerceToFloat(((Complex) obj)
4633: .getImaginaryPart());
4634: phase = new LispFloat(Math.atan2(im.getValue(), re
4635: .getValue())); // atan(y/x)
4636: abs = (LispFloat) ((Complex) obj).ABS();
4637: return Complex.getInstance(new LispFloat(Math.log(abs
4638: .getValue())), phase);
4639: }
4640: }
4641:
4642: throw new ConditionThrowable(new TypeError(obj, "number"));
4643: }
4644:
4645: // ### gcd-2
4646: private static final Primitive2 GCD_2 = new Primitive2("gcd-2",
4647: PACKAGE_SYS, false) {
4648: public LispObject execute(LispObject first, LispObject second)
4649: throws ConditionThrowable {
4650: BigInteger n1, n2;
4651: if (first instanceof Fixnum)
4652: n1 = BigInteger.valueOf(((Fixnum) first).getValue());
4653: else if (first instanceof Bignum)
4654: n1 = ((Bignum) first).getValue();
4655: else
4656: throw new ConditionThrowable(new TypeError(first,
4657: "integer"));
4658: if (second instanceof Fixnum)
4659: n2 = BigInteger.valueOf(((Fixnum) second).getValue());
4660: else if (second instanceof Bignum)
4661: n2 = ((Bignum) second).getValue();
4662: else
4663: throw new ConditionThrowable(new TypeError(second,
4664: "integer"));
4665: return number(n1.gcd(n2));
4666: }
4667: };
4668:
4669: // ### hashcode-to-string
4670: private static final Primitive1 HASHCODE_TO_STRING = new Primitive1(
4671: "hashcode-to-string", PACKAGE_SYS, false) {
4672: public LispObject execute(LispObject arg)
4673: throws ConditionThrowable {
4674: return new LispString(Integer.toHexString(System
4675: .identityHashCode(arg)));
4676: }
4677: };
4678:
4679: static {
4680: new Primitives();
4681: }
4682: }
|