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