0001: /*
0002: * Jatha - a Common LISP-compatible LISP library in Java.
0003: * Copyright (C) 1997-2005 Micheal Scott Hewett
0004: *
0005: * This library is free software; you can redistribute it and/or
0006: * modify it under the terms of the GNU Lesser General Public
0007: * License as published by the Free Software Foundation; either
0008: * version 2.1 of the License, or (at your option) any later version.
0009: *
0010: * This library is distributed in the hope that it will be useful,
0011: * but WITHOUT ANY WARRANTY; without even the implied warranty of
0012: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
0013: * Lesser General Public License for more details.
0014: *
0015: * You should have received a copy of the GNU Lesser General Public
0016: * License along with this library; if not, write to the Free Software
0017: * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
0018: *
0019: *
0020: * For further information, please contact Micheal Hewett at
0021: * hewett@cs.stanford.edu
0022: *
0023: */
0024:
0025: package org.jatha.compile;
0026:
0027: import java.util.Stack;
0028: import java.util.Map;
0029: import java.util.HashMap;
0030:
0031: import org.jatha.Jatha;
0032: import org.jatha.dynatype.*;
0033: import org.jatha.machine.*;
0034:
0035: /**
0036: * LispCompiler has a <tt>compile()</tt> method that will
0037: * compile a LISP expression and return the SECD code
0038: * for that expression.
0039: *
0040: *
0041: * Example LISP read/eval/print loop:
0042: * <pre>
0043: * expr = parser.read(stream);
0044: * code = compiler.compile(expr);
0045: * result = machine.eval(code);
0046: * result.print();
0047: * </pre>
0048: * <p>
0049: * Macro compilation contributed by Jean-Pierre Gaillardon, April 2005
0050: * </p>
0051: * @see org.jatha.machine.SECDMachine
0052: * @see org.jatha.machine.SECDop
0053: * @author Micheal S. Hewett hewett@cs.stanford.edu
0054: */
0055: public class LispCompiler {
0056: // Set this to true to produce debugging output during compilation.
0057: static boolean DEBUG = false;
0058:
0059: // These are special forms that get expanded in the compiler
0060: LispValue AND;
0061: LispValue DEFMACRO;
0062: LispValue DEFUN;
0063: LispValue IF;
0064: LispValue LAMBDA;
0065: LispValue LET;
0066: LispValue LETREC;
0067: LispValue OR;
0068: LispValue PRIMITIVE;
0069: LispValue PROGN;
0070: LispValue QUOTE;
0071: LispValue SETQ;
0072: // LispValue BLOCK;
0073: // LispValue WHEN;
0074:
0075: LispValue AMP_REST; // keyword &rest used in parameters list
0076: LispValue MACRO; // keyword used at begenning of macro code to detect macro
0077: LispValue DUMMY_FUNCTION; // used for recursive definions
0078: LispValue DUMMY_MACRO; // used for recursive definions
0079:
0080: boolean WarnAboutSpecialsP = false; // todo: Need some way to turn this on.
0081: private Jatha f_lisp = null;
0082: private final Stack legalBlocks = new Stack();
0083: private final Stack legalTags = new Stack();
0084: private final Map registeredDos = new HashMap();
0085:
0086: // static initializer.
0087: private void initializeConstants() {
0088: final LispPackage keyPkg = (LispPackage) (f_lisp
0089: .findPackage("KEYWORD"));
0090: final LispPackage sysPkg = (LispPackage) (f_lisp
0091: .findPackage("SYSTEM"));
0092:
0093: AMP_REST = f_lisp.EVAL.intern("&REST", sysPkg);
0094: sysPkg.export(AMP_REST);
0095: AND = f_lisp.EVAL.intern("AND", sysPkg);
0096: sysPkg.export(AND);
0097: DEFMACRO = f_lisp.EVAL.intern("DEFMACRO", sysPkg);
0098: sysPkg.export(DEFMACRO);
0099: DEFUN = f_lisp.EVAL.intern("DEFUN", sysPkg);
0100: sysPkg.export(DEFUN);
0101: IF = f_lisp.EVAL.intern("IF", sysPkg);
0102: sysPkg.export(IF);
0103: LAMBDA = f_lisp.EVAL.intern("LAMBDA", sysPkg);
0104: sysPkg.export(LAMBDA);
0105: LET = f_lisp.EVAL.intern("LET", sysPkg);
0106: sysPkg.export(LET);
0107: LETREC = f_lisp.EVAL.intern("LETREC", sysPkg);
0108: sysPkg.export(LETREC);
0109: MACRO = f_lisp.EVAL.intern("MACRO", keyPkg);
0110: keyPkg.export(MACRO);
0111: OR = f_lisp.EVAL.intern("OR", sysPkg);
0112: sysPkg.export(OR);
0113: PROGN = f_lisp.EVAL.intern("PROGN", sysPkg);
0114: sysPkg.export(PROGN);
0115: PRIMITIVE = f_lisp.EVAL.intern("PRIMITIVE", keyPkg);
0116: keyPkg.export(PRIMITIVE);
0117: QUOTE = f_lisp.EVAL.intern("QUOTE", sysPkg);
0118: sysPkg.export(QUOTE);
0119: SETQ = f_lisp.EVAL.intern("SETQ", sysPkg);
0120: sysPkg.export(SETQ);
0121: // BLOCK = f_lisp.EVAL.intern("BLOCK",sysPkg);
0122: // sysPkg.export(BLOCK);
0123: // WHEN = f_lisp.EVAL.intern("WHEN");
0124:
0125: //##JPG added
0126: // should be used only to test type. basic_macrop() retutns true for DUMMY_MACRO and false for DUMMY_FUNCTION
0127: DUMMY_FUNCTION = new StandardLispFunction(f_lisp, null, f_lisp
0128: .makeCons(f_lisp.T, f_lisp.NIL));
0129: DUMMY_MACRO = new StandardLispMacro(f_lisp, null, f_lisp
0130: .makeCons(f_lisp.T, f_lisp.NIL));
0131:
0132: }
0133:
0134: public LispCompiler(Jatha lisp) {
0135: super ();
0136:
0137: f_lisp = lisp;
0138:
0139: initializeConstants();
0140: }
0141:
0142: // @author Micheal S. Hewett hewett@cs.stanford.edu
0143: // @date Wed Feb 5 09:33:27 1997
0144: /**
0145: * Initializes the compiler by registering
0146: * the LISP primitive functions so that the
0147: * compiler can recognize them.
0148: *
0149: * @see org.jatha.compile.LispCompiler
0150: */
0151: public void init() {
0152: // Here put a call to in-package, then to export. for these things. I guess register should call export.
0153: final LispPackage SYSTEM_PKG = (LispPackage) f_lisp
0154: .findPackage("SYSTEM");
0155: Register(new AbsoluteValuePrimitive(f_lisp), SYSTEM_PKG);
0156: Register(new AppendPrimitive(f_lisp), SYSTEM_PKG);
0157: Register(new ApplyPrimitive(f_lisp), SYSTEM_PKG);
0158: Register(new AproposPrimitive(f_lisp), SYSTEM_PKG);
0159: Register(new ArcSinePrimitive(f_lisp), SYSTEM_PKG);
0160: Register(new ArcCosinePrimitive(f_lisp), SYSTEM_PKG);
0161: Register(new ArcTangentPrimitive(f_lisp), SYSTEM_PKG);
0162: Register(new ArcTangent2Primitive(f_lisp), SYSTEM_PKG);
0163: Register(new AssocPrimitive(f_lisp), SYSTEM_PKG);
0164: Register(new AtomPrimitive(f_lisp), SYSTEM_PKG);
0165: // Register(new BackquotePrimitive(f_lisp), (LispPackage)f_lisp.findPackage("SYSTEM"));
0166: Register(new BoundpPrimitive(f_lisp), SYSTEM_PKG);
0167: Register(new BlockPrimitive(f_lisp), SYSTEM_PKG);
0168: Register(new ButlastPrimitive(f_lisp), SYSTEM_PKG);
0169: Register(new CarPrimitive(f_lisp), SYSTEM_PKG);
0170: Register(new CdrPrimitive(f_lisp), SYSTEM_PKG);
0171: Register(new CeilingPrimitive(f_lisp), SYSTEM_PKG);
0172: Register(new CharacterpPrimitive(f_lisp), SYSTEM_PKG);
0173: Register(new ClrhashPrimitive(f_lisp), SYSTEM_PKG);
0174: Register(new ConcatenatePrimitive(f_lisp), SYSTEM_PKG);
0175: Register(new ConsPrimitive(f_lisp), SYSTEM_PKG);
0176: Register(new ConspPrimitive(f_lisp), SYSTEM_PKG);
0177: Register(new ConstantpPrimitive(f_lisp), SYSTEM_PKG);
0178: Register(new CopyListPrimitive(f_lisp), SYSTEM_PKG);
0179: Register(new CosecantPrimitive(f_lisp), SYSTEM_PKG);
0180: Register(new CosinePrimitive(f_lisp), SYSTEM_PKG);
0181: Register(new CotangentPrimitive(f_lisp), SYSTEM_PKG);
0182: Register(new DefconstantPrimitive(f_lisp), SYSTEM_PKG);
0183: Register(new DefparameterPrimitive(f_lisp), SYSTEM_PKG);
0184: Register(new DefvarPrimitive(f_lisp), SYSTEM_PKG);
0185: Register(new DegreesToRadiansPrimitive(f_lisp), SYSTEM_PKG);
0186: Register(new DocumentationPrimitive(f_lisp), SYSTEM_PKG);
0187: Register(new SetfDocumentationPrimitive(f_lisp), SYSTEM_PKG);
0188: Register(new EighthPrimitive(f_lisp), SYSTEM_PKG);
0189: Register(new EltPrimitive(f_lisp), SYSTEM_PKG);
0190: Register(new EqPrimitive(f_lisp), SYSTEM_PKG);
0191: Register(new EqlPrimitive(f_lisp), SYSTEM_PKG);
0192: Register(new EqualNumericPrimitive(f_lisp), SYSTEM_PKG);
0193: Register(new ExitPrimitive(f_lisp), SYSTEM_PKG);
0194: Register(new EvalPrimitive(f_lisp), SYSTEM_PKG);
0195: Register(new FactorialPrimitive(f_lisp), SYSTEM_PKG);
0196: Register(new FboundpPrimitive(f_lisp), SYSTEM_PKG);
0197: Register(new FindPackagePrimitive(f_lisp), SYSTEM_PKG);
0198: Register(new MakepackagePrimitive(f_lisp), SYSTEM_PKG);
0199: Register(new UsePackagePrimitive(f_lisp), SYSTEM_PKG);
0200: Register(new PackageUseListPrimitive(f_lisp), SYSTEM_PKG);
0201: Register(new PackageNamePrimitive(f_lisp), SYSTEM_PKG);
0202: Register(new PackageNicknamesPrimitive(f_lisp), SYSTEM_PKG);
0203: Register(new ImportPrimitive(f_lisp), SYSTEM_PKG);
0204: Register(new ExportPrimitive(f_lisp), SYSTEM_PKG);
0205: Register(new ShadowPrimitive(f_lisp), SYSTEM_PKG);
0206: Register(new ShadowingImportPrimitive(f_lisp), SYSTEM_PKG);
0207: Register(new FifthPrimitive(f_lisp), SYSTEM_PKG);
0208: Register(new FirstPrimitive(f_lisp), SYSTEM_PKG);
0209: Register(new FloatpPrimitive(f_lisp), SYSTEM_PKG);
0210: Register(new FloorPrimitive(f_lisp), SYSTEM_PKG);
0211: Register(new FuncallPrimitive(f_lisp), SYSTEM_PKG);
0212: Register(new FunctionPrimitive(f_lisp), SYSTEM_PKG);
0213: Register(new FourthPrimitive(f_lisp), SYSTEM_PKG);
0214: Register(new GrindefPrimitive(f_lisp), SYSTEM_PKG);
0215: Register(new GethashPrimitive(f_lisp), SYSTEM_PKG);
0216: Register(new GoPrimitive(f_lisp), SYSTEM_PKG);
0217: Register(new GreaterThanPrimitive(f_lisp), SYSTEM_PKG);
0218: Register(new GreaterThanOrEqualPrimitive(f_lisp), SYSTEM_PKG);
0219: Register(new SetfGethashPrimitive(f_lisp), SYSTEM_PKG);
0220: Register(new HashtablepPrimitive(f_lisp), SYSTEM_PKG);
0221: Register(new HashtableCountPrimitive(f_lisp), SYSTEM_PKG);
0222: Register(new HashtableRehashSizePrimitive(f_lisp), SYSTEM_PKG);
0223: Register(new HashtableRehashThresholdPrimitive(f_lisp),
0224: SYSTEM_PKG);
0225: Register(new HashtableSizePrimitive(f_lisp), SYSTEM_PKG);
0226: Register(new HashtableTestPrimitive(f_lisp), SYSTEM_PKG);
0227: Register(new IntegerpPrimitive(f_lisp), SYSTEM_PKG);
0228: Register(new InternPrimitive(f_lisp), SYSTEM_PKG);
0229: Register(new KeywordpPrimitive(f_lisp), SYSTEM_PKG);
0230: Register(new LastPrimitive(f_lisp), SYSTEM_PKG);
0231: Register(new LengthPrimitive(f_lisp), SYSTEM_PKG);
0232: Register(new LessThanPrimitive(f_lisp), SYSTEM_PKG);
0233: Register(new LessThanOrEqualPrimitive(f_lisp), SYSTEM_PKG);
0234: Register(new ListPrimitive(f_lisp), SYSTEM_PKG);
0235: Register(new ListStarPrimitive(f_lisp), SYSTEM_PKG);
0236: Register(new ListAllPackagesPrimitive(f_lisp), SYSTEM_PKG);
0237: Register(new ListpPrimitive(f_lisp), SYSTEM_PKG);
0238: Register(new LoadPrimitive(f_lisp), SYSTEM_PKG);
0239: Register(new LoadFromJarPrimitive(f_lisp), SYSTEM_PKG);
0240: Register(new Macroexpand1Primitive(f_lisp), SYSTEM_PKG);
0241: Register(new MacroexpandPrimitive(f_lisp), SYSTEM_PKG);
0242: Register(new MakeHashTablePrimitive(f_lisp), SYSTEM_PKG);
0243: Register(new MaxPrimitive(f_lisp), SYSTEM_PKG);
0244: Register(new MemberPrimitive(f_lisp), SYSTEM_PKG);
0245: Register(new MinPrimitive(f_lisp), SYSTEM_PKG);
0246: Register(new NconcPrimitive(f_lisp), SYSTEM_PKG);
0247: Register(new NinthPrimitive(f_lisp), SYSTEM_PKG);
0248: Register(new NotPrimitive(f_lisp), SYSTEM_PKG);
0249: Register(new NreversePrimitive(f_lisp), SYSTEM_PKG);
0250: Register(new NStringCapitalizePrimitive(f_lisp), SYSTEM_PKG);
0251: Register(new NStringDowncasePrimitive(f_lisp), SYSTEM_PKG);
0252: Register(new NStringUpcasePrimitive(f_lisp), SYSTEM_PKG);
0253: Register(new NullPrimitive(f_lisp), SYSTEM_PKG);
0254: Register(new NumberpPrimitive(f_lisp), SYSTEM_PKG);
0255: Register(new PopPrimitive(f_lisp), SYSTEM_PKG);
0256: Register(new PositionPrimitive(f_lisp), SYSTEM_PKG);
0257: Register(new Prin1Primitive(f_lisp), SYSTEM_PKG);
0258: Register(new PrincPrimitive(f_lisp), SYSTEM_PKG);
0259: Register(new PrintPrimitive(f_lisp), SYSTEM_PKG);
0260: Register(new PushPrimitive(f_lisp), SYSTEM_PKG);
0261: Register(new QuotePrimitive(f_lisp), SYSTEM_PKG);
0262: Register(new RadiansToDegreesPrimitive(f_lisp), SYSTEM_PKG);
0263: Register(new RassocPrimitive(f_lisp), SYSTEM_PKG);
0264: Register(new ReadFromStringPrimitive(f_lisp), SYSTEM_PKG);
0265: Register(new ReciprocalPrimitive(f_lisp), SYSTEM_PKG);
0266: Register(new RemhashPrimitive(f_lisp), SYSTEM_PKG);
0267: Register(new RemovePrimitive(f_lisp), SYSTEM_PKG);
0268: Register(new RestPrimitive(f_lisp), SYSTEM_PKG);
0269: Register(new ReturnFromPrimitive(f_lisp), SYSTEM_PKG);
0270: Register(new ReversePrimitive(f_lisp), SYSTEM_PKG);
0271: Register(new RplacaPrimitive(f_lisp), SYSTEM_PKG);
0272: Register(new RplacdPrimitive(f_lisp), SYSTEM_PKG);
0273: Register(new SecantPrimitive(f_lisp), SYSTEM_PKG);
0274: Register(new SecondPrimitive(f_lisp), SYSTEM_PKG);
0275: Register(new SetPrimitive(f_lisp), SYSTEM_PKG);
0276: Register(new SetfSymbolFunctionPrimitive(f_lisp), SYSTEM_PKG);
0277: Register(new SetfSymbolPlistPrimitive(f_lisp), SYSTEM_PKG);
0278: Register(new SetfSymbolValuePrimitive(f_lisp), SYSTEM_PKG);
0279: Register(new SetqPrimitive(f_lisp), SYSTEM_PKG);
0280: Register(new SeventhPrimitive(f_lisp), SYSTEM_PKG);
0281: Register(new SinePrimitive(f_lisp), SYSTEM_PKG);
0282: Register(new SixthPrimitive(f_lisp), SYSTEM_PKG);
0283: Register(new StringpPrimitive(f_lisp), SYSTEM_PKG);
0284: Register(new SquareRootPrimitive(f_lisp), SYSTEM_PKG);
0285: Register(new StringPrimitive(f_lisp), SYSTEM_PKG);
0286: Register(new StringUpcasePrimitive(f_lisp), SYSTEM_PKG);
0287: Register(new StringDowncasePrimitive(f_lisp), SYSTEM_PKG);
0288: Register(new StringCapitalizePrimitive(f_lisp), SYSTEM_PKG);
0289: Register(new StringEndsWithPrimitive(f_lisp), SYSTEM_PKG);
0290: Register(new StringEqualPrimitive(f_lisp), SYSTEM_PKG);
0291: Register(new StringEqPrimitive(f_lisp), SYSTEM_PKG);
0292: Register(new StringNeqPrimitive(f_lisp), SYSTEM_PKG);
0293: Register(new StringLessThanPrimitive(f_lisp), SYSTEM_PKG);
0294: Register(new StringLesspPrimitive(f_lisp), SYSTEM_PKG);
0295: Register(new StringGreaterThanPrimitive(f_lisp), SYSTEM_PKG);
0296: Register(new StringGreaterpPrimitive(f_lisp), SYSTEM_PKG);
0297: Register(new StringLessThanOrEqualPrimitive(f_lisp), SYSTEM_PKG);
0298: Register(new StringGreaterThanOrEqualPrimitive(f_lisp),
0299: SYSTEM_PKG);
0300: Register(new StringNotLesspPrimitive(f_lisp), SYSTEM_PKG);
0301: Register(new StringNotGreaterpPrimitive(f_lisp), SYSTEM_PKG);
0302: Register(new StringStartsWithPrimitive(f_lisp), SYSTEM_PKG);
0303: Register(new StringTrimPrimitive(f_lisp), SYSTEM_PKG);
0304: Register(new StringLeftTrimPrimitive(f_lisp), SYSTEM_PKG);
0305: Register(new StringRightTrimPrimitive(f_lisp), SYSTEM_PKG);
0306:
0307: Register(new SubstPrimitive(f_lisp), SYSTEM_PKG);
0308: Register(new SymbolpPrimitive(f_lisp), SYSTEM_PKG);
0309: Register(new SymbolFunctionPrimitive(f_lisp), SYSTEM_PKG);
0310: Register(new SymbolNamePrimitive(f_lisp), SYSTEM_PKG);
0311: Register(new SymbolPackagePrimitive(f_lisp), SYSTEM_PKG);
0312: Register(new SymbolPlistPrimitive(f_lisp), SYSTEM_PKG);
0313: Register(new SymbolValuePrimitive(f_lisp), SYSTEM_PKG);
0314: Register(new TagbodyPrimitive(f_lisp), SYSTEM_PKG);
0315: Register(new TangentPrimitive(f_lisp), SYSTEM_PKG);
0316: Register(new TenthPrimitive(f_lisp), SYSTEM_PKG);
0317: Register(new ThirdPrimitive(f_lisp), SYSTEM_PKG);
0318: Register(new TimePrimitive(f_lisp), SYSTEM_PKG);
0319: Register(new TypeOfPrimitive(f_lisp), SYSTEM_PKG);
0320: Register(new ZeropPrimitive(f_lisp), SYSTEM_PKG);
0321:
0322: Register(new AddPrimitive(f_lisp), SYSTEM_PKG);
0323: Register(new DividePrimitive(f_lisp), SYSTEM_PKG);
0324: Register(new MultiplyPrimitive(f_lisp), SYSTEM_PKG);
0325: Register(new SubtractPrimitive(f_lisp), SYSTEM_PKG);
0326: Register(new AddOnePrimitive(f_lisp), SYSTEM_PKG); /* 1+ */
0327: Register(new SubtractOnePrimitive(f_lisp), SYSTEM_PKG); /* 1- */
0328:
0329: Register(new TracePrimitive(f_lisp), SYSTEM_PKG);
0330: Register(new GcPrimitive(f_lisp), SYSTEM_PKG);
0331: Register(new GcFullPrimitive(f_lisp), SYSTEM_PKG);
0332: Register(new FreePrimitive(f_lisp), SYSTEM_PKG);
0333: }
0334:
0335: // @author Micheal S. Hewett hewett@cs.stanford.edu
0336: // @date Wed Feb 5 09:45:51 1997
0337: /**
0338: * Use this function to register any new LISP primitives
0339: * that you create from Java code. The compiler will
0340: * then recognize them and compile them appropriately.
0341: *
0342: * Example:
0343: * <pre>
0344: * compiler.Register(new RevAppendPrimitive());
0345: * </pre>
0346: * @see LispPrimitive
0347: * @param primitive
0348: */
0349: public void Register(LispPrimitive primitive) {
0350: Register(primitive, f_lisp.PACKAGE);
0351: }
0352:
0353: /**
0354: * Use this function to register any new LISP primitives
0355: * that you create from Java code. The compiler will
0356: * then recognize them and compile them appropriately.
0357: * This version of the constructor accepts a package in which
0358: * to intern the symbol.
0359: *
0360: * Example:
0361: * <pre>
0362: * compiler.Register(new RevAppendPrimitive());
0363: * </pre>
0364: * @see LispPrimitive
0365: * @param primitive
0366: */
0367: public void Register(LispPrimitive primitive, LispPackage pkg) {
0368: final LispValue symbol = f_lisp.getEval().intern(
0369: primitive.LispFunctionNameString(), pkg);
0370: symbol.setf_symbol_function(f_lisp.makeList(PRIMITIVE,
0371: primitive));
0372: pkg.export(symbol);
0373:
0374: }
0375:
0376: /**
0377: * Use this function to register any new LISP primitives
0378: * that you create from Java code. The compiler will
0379: * then recognize them and compile them appropriately.
0380: * This version of the constructor accepts a package in which
0381: * to intern the symbol.
0382: *
0383: * Example:
0384: * <pre>
0385: * compiler.Register(new RevAppendPrimitive());
0386: * </pre>
0387: * @see LispPrimitive
0388: * @param primitive
0389: */
0390: public void Register(LispPrimitive primitive, String pkgName) {
0391: Register(primitive, (LispPackage) (f_lisp.findPackage(pkgName)));
0392: }
0393:
0394: public Stack getLegalBlocks() {
0395: return legalBlocks;
0396: }
0397:
0398: public Stack getLegalTags() {
0399: return legalTags;
0400: }
0401:
0402: public Map getRegisteredDos() {
0403: return registeredDos;
0404: }
0405:
0406: public boolean isLegalTag(final LispValue tag) {
0407: for (final java.util.Iterator iter = legalTags.iterator(); iter
0408: .hasNext();) {
0409: if (((java.util.Set) iter.next()).contains(tag)) {
0410: return true;
0411: }
0412: }
0413: return false;
0414: }
0415:
0416: /* --- Compiler flags --- */
0417:
0418: public void WarnAboutSpecials(boolean value) {
0419: WarnAboutSpecialsP = value;
0420: }
0421:
0422: /* --- Utility routines --- */
0423:
0424: /* LispValue loc(long y, LispValue z)
0425: {
0426: if (y == 1)
0427: return(z.car());
0428: else
0429: return loc(y-1, z.cdr());
0430: }
0431:
0432:
0433: LispValue getComponentAt(LispValue ij_indexes, LispValue valueList)
0434: {
0435: long i, j;
0436:
0437: i = ((LispInteger)(ij_indexes.car())).getLongValue();
0438: j = ((LispInteger)(ij_indexes.cdr())).getLongValue();
0439:
0440: return loc(j, loc(i, valueList));
0441: }
0442:
0443:
0444: LispValue index2(LispValue e, LispValue n, long j)
0445: {
0446: if (n == f_lisp.NIL)
0447: return n;
0448: else if (n.car() == e)
0449: return f_lisp.makeInteger(j);
0450: else
0451: return index2(e, n.cdr(), j+1);
0452: }
0453:
0454:
0455: LispValue index_aux(LispValue e, LispValue n, long i)
0456: {
0457: if (n == f_lisp.NIL)
0458: return n;
0459: else
0460: {
0461: LispValue j;
0462:
0463: j = index2(e, n.car(), 1);
0464:
0465: if (j == f_lisp.NIL)
0466: return index_aux(e, n.cdr(), i+1);
0467: else
0468: return f_lisp.makeCons(f_lisp.makeInteger(i), j);
0469: }
0470: }
0471:
0472: /**
0473: * Looks up the symbol in a list of lists.
0474: * Returns the index of the list in which it is found and
0475: * the index in that list.
0476: * Both indexes start from 1.
0477: * Returns NIL if not found.
0478: * Examples:
0479: * <pre>
0480: * index(b, ((a b c) (d e f)) = (1 . 2)
0481: * index(f, ((a b c) (d e f)) = (2 . 3)
0482: * index(z, ((a b c) (d e f)) = NIL
0483: * </pre>
0484: * @param e a Symbol
0485: * @param n a list of lists
0486: * @return either NIL, if not found, or a Cons of 2 LispIntegers (a . b) indicating list number (a) and index into that list (b)
0487: */
0488: /* LispValue index(LispValue e, LispValue n)
0489: {
0490: return index_aux(e, n, 1);
0491: }
0492: */
0493:
0494: // New IndexInList and IndexAndAttributes contributed by
0495: // Jean-Pierre Gaillardon, April 2005
0496: /**
0497: * Looks up the symbol in a list
0498: * @param e a Symbol
0499: * @param l a list
0500: * @param attribute The attribute of the found symbol is assigned to attribute[0]. It can be NIL or &rest
0501: * @return the index in list of found symbol (it start from 1) or 0 if symbol has not been found in list
0502: */
0503: public int indexInList(LispValue e, LispValue l,
0504: LispValue[] attribute) {
0505: int indexInList = 1;
0506: LispValue list = l;
0507: LispValue previousAttribute = f_lisp.NIL;
0508: for (;; list = list.cdr()) {
0509: if (list == f_lisp.NIL) {
0510: return 0; // not found
0511: }
0512: LispValue elt = list.car();
0513: if (elt == AMP_REST) {
0514: previousAttribute = AMP_REST;
0515: continue;
0516: }
0517: if (elt == e) {
0518: attribute[0] = previousAttribute;
0519: return indexInList;
0520: }
0521: previousAttribute = f_lisp.NIL;
0522: indexInList++;
0523: }
0524: }
0525:
0526: // New IndexInList and IndexAndAttributes contributed by
0527: // Jean-Pierre Gaillardon, April 2005
0528: /**
0529: * Looks up the symbol in a list of lists.
0530: * Returns a dotted pair.
0531: * - first element is the attribute of the found symbol
0532: * it can be "&rest" or NIL for no attribute (or if symbol has not been found)
0533: * - second element is the index of the list in which it is found and
0534: * the index in that list. Both indexes start from 1. The &rest keyword eventually
0535: * present in the list is not taken into account for index count.
0536: * index is NIL if not found.
0537: * Examples:
0538: * <pre>
0539: * indexAndAttribute(b, ((a b c) (d e f)) = (NIL. (1 . 2))
0540: * indexAndAttribute(f, ((a b c) (d e f)) = (NIL.(2 . 3))
0541: * indexAndAttribute(z, ((a b c) (d e f)) = (NIL. NIL)
0542: * indexAndAttribute(l, ((a &rest l) (d e f)) = (&rest .(1 . 2))
0543: * </pre>
0544: * @param e a Symbol
0545: * @param l a list of lists
0546: * @return either (NIL.NIL), if not found, or a dotted pair; first is the attribute for symbol, second is a Cons of 2 LispIntegers\
0547: (a . b) indicating list number (a) and index into that list (b)
0548: */
0549: public LispValue indexAndAttribute(LispValue e, LispValue l) {
0550: int indexSubList = 1;
0551: LispValue subList = l;
0552: LispValue[] attribute = new LispValue[] { f_lisp.NIL };
0553:
0554: for (;; indexSubList++, subList = subList.cdr()) {
0555: if (subList == f_lisp.NIL) {
0556: return f_lisp.makeCons(f_lisp.NIL, f_lisp.NIL); // not found
0557: }
0558: int indexInSubList = indexInList(e, subList.car(),
0559: attribute);
0560: if (indexInSubList != 0) // found
0561: {
0562: LispValue position = f_lisp.makeCons(f_lisp.makeCons(
0563: f_lisp.makeInteger(indexSubList), f_lisp
0564: .makeInteger(indexInSubList)),
0565: f_lisp.NIL);
0566: return f_lisp.makeCons(attribute[0], position);
0567: }
0568: }
0569: }
0570:
0571: // This places the args on the stack so that they will be evaluated L->R,
0572: // as is required in Common LISP.
0573: //
0574: public LispValue compileArgsLeftToRight(LispValue args,
0575: LispValue valueList, LispValue code)
0576: throws CompilerException {
0577: if (args == f_lisp.NIL)
0578: return code;
0579: else
0580: return compile(args.car(), valueList,
0581: compileArgsLeftToRight(args.cdr(), valueList, code));
0582: }
0583:
0584: // This places the args on the stack L->R, but unevaluated.
0585: //
0586: public LispValue compileConstantArgsLeftToRight(
0587: SECDMachine machine, LispValue args, LispValue valueList,
0588: LispValue code) {
0589: if (args == f_lisp.NIL)
0590: return code;
0591: else
0592: return f_lisp.makeCons(machine.LDC, f_lisp.makeCons(args
0593: .car(), compileConstantArgsLeftToRight(machine,
0594: args.cdr(), valueList, code)));
0595: }
0596:
0597: /**
0598: * Returns the input list with quotes added before every
0599: * top-level expression.
0600: */
0601: public LispValue quoteList(LispValue l) {
0602: if (l == f_lisp.NIL)
0603: return l;
0604: else
0605: return f_lisp.makeCons(f_lisp.makeList(QUOTE, l.car()),
0606: quoteList(l.cdr()));
0607: }
0608:
0609: // @author Micheal S. Hewett hewett@cs.stanford.edu
0610: // @date Sun Feb 2 19:46:35 1997
0611: /**
0612: * <tt>compile</tt> takes a LISP expression, a list of
0613: * global variables, and optionally an already-generated
0614: * list of code. It returns compiled code in a list.
0615: *
0616: * @see LispCompiler
0617: * @param expr expression to compile
0618: * @param varValues global or local variable list.
0619: * @return LispValue - generated code
0620: */
0621: public LispValue compile(SECDMachine machine, LispValue expr,
0622: LispValue varValues) throws CompilerException {
0623: if (DEBUG) {
0624: System.out.println("expr = " + expr);
0625: System.out.println("varValues = " + varValues);
0626: System.out.println("STOP = " + machine.STOP);
0627: System.out.println("NIL = " + f_lisp.NIL);
0628: System.out.println("initial code = "
0629: + f_lisp.makeCons(machine.STOP, f_lisp.NIL));
0630: }
0631:
0632: return compile(expr, varValues, f_lisp.makeCons(machine.STOP,
0633: f_lisp.NIL));
0634: }
0635:
0636: // @author Micheal S. Hewett hewett@cs.stanford.edu
0637: // @date Sun Feb 2 19:46:35 1997
0638: /**
0639: * <tt>compile</tt> takes a LISP expression, a list of
0640: * global variables, and optionally an already-generated
0641: * list of code. It returns compiled code in a list.
0642: *
0643: * @see LispCompiler
0644: * @param expr expression to compile
0645: * @param valueList global variable list.
0646: * @param code [optional]
0647: * @return LispValue - generated code
0648: */
0649: public LispValue compile(LispValue expr, LispValue valueList,
0650: LispValue code) throws CompilerException {
0651: if (DEBUG) {
0652: System.out.print("\nCompile: " + expr);
0653: System.out.print("\n code: " + code);
0654: }
0655:
0656: if (!expr.basic_atom())
0657: return compileList(f_lisp.MACHINE, expr, valueList, code);
0658: else
0659: return compileAtom(f_lisp.MACHINE, expr, valueList, code);
0660: }
0661:
0662: LispValue compileAtom(SECDMachine machine, LispValue expr,
0663: LispValue valueList, LispValue code)
0664: throws CompilerException {
0665: if (DEBUG) {
0666: System.out.print("\nCompile Atom: " + expr);
0667: System.out.print(" of type " + expr.getClass().getName());
0668: System.out.flush();
0669: }
0670:
0671: if (expr == f_lisp.NIL)
0672: return (f_lisp.makeCons(machine.NIL, code));
0673: else if (expr == f_lisp.T)
0674: return (f_lisp.makeCons(machine.T, code));
0675:
0676: else if ((expr.symbolp() == f_lisp.NIL) // Self-evaluating atom
0677: || (expr.keywordp() == f_lisp.T))
0678: return (f_lisp.makeCons(machine.LDC, f_lisp.makeCons(expr,
0679: code)));
0680:
0681: else /* A symbol. Get its value */
0682: {
0683: //LispValue varIndex = index(expr, valueList);
0684: //##JPG use indexAndAttributes() instead of index
0685: LispValue varIdxAndAttributes = indexAndAttribute(expr,
0686: valueList);
0687: LispValue paramAttribute = varIdxAndAttributes.car();
0688: LispValue varIndex = varIdxAndAttributes.cdr().car();
0689:
0690: if (varIndex == f_lisp.NIL) {
0691: /* Not a local variable, maybe it's global */
0692: if (!expr.specialP() && WarnAboutSpecialsP)
0693: System.err.print("\n;; ** Warning - "
0694: + expr.toString() + " assumed special.\n");
0695:
0696: return (f_lisp.makeCons(machine.LD_GLOBAL, f_lisp
0697: .makeCons(expr, code)));
0698: // else
0699: // throw new UndefinedVariableException(((LispString)(expr.symbol_name())).getValue());
0700: } else /* Found the symbol. Is it bound? */
0701: {
0702: //##JPG opcode LDR instead of LD for variable arguments
0703: // note : paramAttribute can only be nil or &rest
0704: LispValue loadOpCode = (paramAttribute == AMP_REST) ? machine.LDR
0705: : machine.LD;
0706: return (f_lisp.makeCons(loadOpCode, f_lisp.makeCons(
0707: varIndex, code)));
0708: }
0709: /*
0710: return (f_lisp.makeCons(machine.LD,
0711: f_lisp.makeCons(varIndex, code)));
0712: */
0713: }
0714: }
0715:
0716: LispValue compileList(SECDMachine machine, LispValue expr,
0717: LispValue valueList, LispValue code)
0718: throws CompilerException {
0719: LispValue function = expr.car();
0720: LispValue args = expr.cdr();
0721:
0722: if (DEBUG)
0723: System.out.print("\nCompile List: " + expr);
0724:
0725: // User-defined function
0726: if (function.basic_functionp()) {
0727: LispFunction lFunc = (LispFunction) function;
0728: if (lFunc.isBuiltin())
0729: return compileBuiltin(machine, function, args,
0730: valueList, code);
0731: else
0732: return compileUserDefinedFunction(machine, function,
0733: args, valueList, code);
0734: }
0735:
0736: // Function on a symbol
0737: else if (function.basic_atom()) {
0738: if (isBuiltinFunction(function)) {
0739: return compileBuiltin(machine, function, args,
0740: valueList, code);
0741: }
0742:
0743: else if (specialFormP(function)) // LAMBDA, DEFUN, LET, ...
0744: return compileSpecialForm(machine, function, args,
0745: valueList, code);
0746:
0747: else // FUNCTION must represent a non-builtin function or macro.
0748: {
0749: // ##JPG compileSpecialForm() has been modified to support DEFMACRO
0750: // LispValue defn = index(function, valueList);
0751: // ##JPG if function has a variable number of parameters (&rest is present in paraameters list)
0752: // the opcode LDR (LoaD with Rest) is used in place of LD
0753: LispValue fnIdxAndAttributes = indexAndAttribute(
0754: function, valueList);
0755: LispValue defn = fnIdxAndAttributes.cdr().car();
0756: LispValue loadOpCode = (fnIdxAndAttributes.car() == AMP_REST) ? machine.LDR
0757: : machine.LD;
0758:
0759: if (defn == f_lisp.NIL) {
0760: try {
0761: defn = ((LispFunction) function
0762: .symbol_function()).getCode();
0763: } catch (LispException e) {
0764: defn = null;
0765: }
0766:
0767: if ((defn == f_lisp.NIL) || (defn == null)) {
0768: if (function instanceof LispSymbol)
0769: throw new UndefinedFunctionException(
0770: ((LispString) (function
0771: .symbol_name())).toString());
0772: else
0773: throw new UndefinedFunctionException(
0774: function.toString());
0775: }
0776: }
0777:
0778: // ##JPG add this if block to compile macro
0779: if (function.symbol_function().basic_macrop())
0780: //------------------------ compile macro --------------------------------
0781: {
0782: if (defn.car().numberp() == f_lisp.T) /* macro present in closure */
0783: {
0784: //##JPG idem compileApp but don't evaluate arguments
0785: return compileAppConstant(
0786: machine,
0787: args,
0788: valueList,
0789: f_lisp
0790: .makeCons(
0791: loadOpCode,
0792: f_lisp
0793: .makeCons(
0794: defn,
0795: (code
0796: .car() == machine.RTN) ? f_lisp
0797: .makeCons(
0798: machine.DAP,
0799: code
0800: .cdr())
0801: : f_lisp
0802: .makeCons(
0803: machine.AP,
0804: code))));
0805:
0806: } else /* Compiled macro */
0807: {
0808: LispValue expandCode = f_lisp
0809: .makeCons(
0810: machine.DUM,
0811: f_lisp
0812: .makeCons(
0813: machine.LDFC,
0814: f_lisp
0815: .makeCons(
0816: function,
0817: f_lisp
0818: .makeCons(
0819: machine.NIL,
0820: f_lisp
0821: .makeCons(
0822: new ConsPrimitive(
0823: f_lisp),
0824: compileLambda(
0825: machine,
0826: expr,
0827: f_lisp
0828: .makeCons(
0829: f_lisp
0830: .makeCons(
0831: function,
0832: f_lisp.NIL),
0833: valueList),
0834: f_lisp
0835: .makeCons(
0836: machine.RAP,
0837: f_lisp.NIL)))))));
0838:
0839: LispValue expandValue = machine.Execute(
0840: expandCode, f_lisp.NIL);
0841: if (DEBUG)
0842: System.out.print("\nMacro " + expr
0843: + " expanded to " + expandValue);
0844: return compile(expandValue, valueList, code);
0845: }
0846: }
0847:
0848: else // compile a function --------------------------------
0849: {
0850: if (defn.car().numberp() == f_lisp.T)
0851: return compileApp(
0852: machine,
0853: args,
0854: valueList,
0855: f_lisp
0856: .makeCons(
0857: loadOpCode,
0858: f_lisp
0859: .makeCons(
0860: defn,
0861: (code
0862: .car() == machine.RTN) ? f_lisp
0863: .makeCons(
0864: machine.DAP,
0865: code
0866: .cdr())
0867: : f_lisp
0868: .makeCons(
0869: machine.AP,
0870: code))));
0871:
0872: else if (defn.car() == LAMBDA) /* Interpreted fn */
0873: return compileApp(machine, args, valueList,
0874: compileLambda(machine,
0875: defn.cdr().cdr(), f_lisp
0876: .makeCons(
0877: defn.second(),
0878: valueList),
0879: code));
0880:
0881: else
0882: /* Compiled fn */
0883: return f_lisp
0884: .makeCons(
0885: machine.DUM,
0886: f_lisp
0887: .makeCons(
0888: machine.LDFC,
0889: f_lisp
0890: .makeCons(
0891: function,
0892: f_lisp
0893: .makeCons(
0894: machine.NIL,
0895: f_lisp
0896: .makeCons(
0897: new ConsPrimitive(
0898: f_lisp),
0899: compileLambda(
0900: machine,
0901: expr,
0902: f_lisp
0903: .makeCons(
0904: f_lisp
0905: .makeCons(
0906: function,
0907: f_lisp.NIL),
0908: valueList),
0909: f_lisp
0910: .makeCons(
0911: machine.RAP,
0912: code)))))));
0913: }
0914: }
0915: }
0916:
0917: else {
0918: /* an application from within a nested function */
0919: return compileApp(machine, args, valueList, compile(
0920: function, valueList,
0921: (code.car() == machine.RTN) ? f_lisp.makeCons(
0922: machine.DAP, code.cdr()) : f_lisp.makeCons(
0923: machine.AP, code)));
0924: }
0925: }
0926:
0927: LispValue compileSpecialForm(SECDMachine machine,
0928: LispValue function, LispValue args, LispValue valueList,
0929: LispValue code) throws CompilerException {
0930: if (DEBUG)
0931: System.out.print("\nCompile Special Form: " + function);
0932:
0933: if (function == PROGN)
0934: return compileProgn(args, valueList, code);
0935: else if (function == LAMBDA)
0936: return compileLambda(machine, f_lisp.makeCons(PROGN, args
0937: .cdr()), f_lisp.makeCons(args.car(), valueList),
0938: code);
0939:
0940: else if (function == DEFUN)
0941: return compileDefun(machine, args.car(), args.cdr(),
0942: valueList, code);
0943:
0944: else if (function == DEFMACRO) // Jatha 2.5.0 April 2005 (JPG)
0945: return compileDefmacro(machine, args.car(), args.cdr(),
0946: valueList, code);
0947:
0948: else if (function == AND)
0949: return compileAnd(machine, args, valueList, code);
0950:
0951: else if (function == OR)
0952: return compileOr(machine, args, valueList, code);
0953:
0954: else if (function == IF)
0955: return compileIf(machine, args.first(), args.second(), args
0956: .third(), valueList, code);
0957:
0958: // Since we now have macro, this is better defined as one.
0959: /* else if (function == WHEN)
0960: return compileIf(machine, args.first(),
0961: f_lisp.makeList(PROGN, args.second()), f_lisp.NIL,
0962: valueList, code);*/
0963:
0964: else if ((function == LET) || (function == LETREC)) {
0965: LispValue vars = varsFromLetBindings(args.first());
0966: LispValue values = valuesFromLetBindings(args.first());
0967: LispValue newValues = f_lisp.makeCons(vars, valueList);
0968:
0969: LispValue body = f_lisp.makeCons(PROGN, args.cdr());
0970:
0971: // Notes: 27 Mar 1997
0972: // For every var that is a special variable, we
0973: // need to have SP_BIND at the beginning and
0974: // SP_UNBIND at the end of the following code.
0975: // (still need to implement SP_BIND and SP_UNBIND as ops).
0976: //
0977: // Note: SETQ must change the latest special binding
0978: // if one exists.
0979: //
0980: // See "./spectest.lisp" for some test routines.
0981:
0982: if (function == LET)
0983: return compileLet(machine, vars, values, valueList,
0984: body, code);
0985: else
0986: /* a LETREC */
0987: return f_lisp.makeCons(machine.DUM, compileApp(machine,
0988: values, newValues, compileLambda(machine, body,
0989: newValues, f_lisp.makeCons(machine.RAP,
0990: code))));
0991: }
0992:
0993: // We have a return for every known branch, but I guess this
0994: // programmer *could* make a mistake sometime, so we'll put an
0995: // error message here.
0996:
0997: System.out.println("\n;; *** Compiler error in CompileAtom");
0998: return f_lisp.NIL;
0999: }
1000:
1001: public LispValue compileLet(SECDMachine machine, LispValue vars,
1002: LispValue values, LispValue valueList, LispValue body,
1003: LispValue code) throws CompilerException {
1004: // Divide the variables into special and non-special var sets.
1005: // Special variables get extra binding instructions.
1006:
1007: LispValue specialVars = f_lisp.NIL;
1008: LispValue specialVals = f_lisp.NIL;
1009: LispValue localVars = f_lisp.NIL;
1010: LispValue localVals = f_lisp.NIL;
1011: LispValue varPtr = vars;
1012: LispValue valPtr = values;
1013:
1014: while (varPtr != f_lisp.NIL) {
1015: if (varPtr.car().specialP()) {
1016: specialVars = f_lisp
1017: .makeCons(varPtr.car(), specialVars);
1018: specialVals = f_lisp
1019: .makeCons(valPtr.car(), specialVals);
1020: } else {
1021: localVars = f_lisp.makeCons(varPtr.car(), localVars);
1022: localVals = f_lisp.makeCons(valPtr.car(), localVals);
1023: }
1024:
1025: varPtr = varPtr.cdr();
1026: valPtr = valPtr.cdr();
1027: }
1028:
1029: // The local vars get compiled by the compileApp,
1030: // the special vars get compiled after that and just
1031: // before the Lambda is compiled.
1032: LispValue ret = compileApp(machine, localVals, valueList,
1033: compileSpecialBind(machine, specialVars, specialVals,
1034: valueList, compileLambda(machine, body, f_lisp
1035: .makeCons(localVars, valueList), f_lisp
1036: .makeCons(machine.AP,
1037: compileSpecialUnbind(machine,
1038: specialVars, code)))));
1039: return ret;
1040: // (code.car() == machine.RTN) ?
1041: // f_lisp.makeCons(machine.DAP, code.cdr())
1042: // : f_lisp.makeCons(machine.AP, code));
1043: }
1044:
1045: // UTILITY functions for LET
1046:
1047: // Inserts special-bind opcode for each var.
1048: LispValue compileSpecialBind(SECDMachine machine, LispValue vars,
1049: LispValue values, LispValue valueList, LispValue code)
1050: throws CompilerException {
1051: if (vars == f_lisp.NIL)
1052: return code;
1053: else
1054: return compile(values.car(), valueList, f_lisp.makeCons(
1055: machine.SP_BIND, f_lisp.makeCons(vars.car(),
1056: compileSpecialBind(machine, vars.cdr(),
1057: values.cdr(), valueList, code))));
1058: }
1059:
1060: // Inserts special-bind opcode for each var.
1061: LispValue compileSpecialUnbind(SECDMachine machine, LispValue vars,
1062: LispValue code) {
1063: if (vars == f_lisp.NIL)
1064: return code;
1065: else
1066: return f_lisp.makeCons(machine.SP_UNBIND, f_lisp.makeCons(
1067: vars.car(), compileSpecialUnbind(machine, vars
1068: .cdr(), code)));
1069: }
1070:
1071: // each entry is (VAR VAL) or VAR. Latter has implied value of NIL.
1072: public LispValue varsFromLetBindings(LispValue varValueList) {
1073: if (varValueList == f_lisp.NIL)
1074: return f_lisp.NIL;
1075: else if (varValueList.car().basic_consp())
1076: return f_lisp.makeCons(varValueList.car().car(),
1077: varsFromLetBindings(varValueList.cdr()));
1078: else
1079: return f_lisp.makeCons(varValueList.car(),
1080: varsFromLetBindings(varValueList.cdr()));
1081: }
1082:
1083: // each entry is (VAR VAL) or VAR. Latter has implied value of NIL.
1084: public LispValue valuesFromLetBindings(LispValue varValueList) {
1085: if (varValueList == f_lisp.NIL)
1086: return f_lisp.NIL;
1087: else if (varValueList.car().basic_consp())
1088: return f_lisp.makeCons(varValueList.car().second(),
1089: valuesFromLetBindings(varValueList.cdr()));
1090: else
1091: return f_lisp.makeCons(f_lisp.NIL,
1092: valuesFromLetBindings(varValueList.cdr()));
1093: }
1094:
1095: /* obsolete 1 Sep 2004 (mh)
1096: boolean builtinFunctionP(LispValue fn)
1097: {
1098: if ((! fn.basic_symbolp()) || (fn.fboundp() != f_lisp.T))
1099: return false;
1100:
1101: LispValue defn = fn.symbol_function();
1102:
1103: if (defn == null)
1104: return false;
1105:
1106: if ((defn.listp() == f_lisp.T) && (defn.first() == PRIMITIVE))
1107: return true;
1108: else
1109: return false;
1110: }
1111: */
1112:
1113: public boolean specialFormP(LispValue fn) {
1114: if ((fn.symbolp() == f_lisp.T)
1115: && ((fn == AND) || (fn == DEFMACRO) || (fn == DEFUN)
1116: || (fn == IF) || (fn == LET) || (fn == LAMBDA)
1117: || (fn == LETREC) || (fn == OR) || (fn == PROGN)
1118: // || (fn == BLOCK)
1119: // || (fn == WHEN)
1120: ))
1121: return true;
1122: else
1123: return false;
1124: }
1125:
1126: // This version of 'compileApp' is modified from the version in Kogge's
1127: // book. It puts args on stack in the correct L->R order and does
1128: // not require the caller to prepend a NIL instruction on the
1129: // resulting code.
1130: LispValue compileApp(SECDMachine machine, LispValue args,
1131: LispValue valueList, LispValue code)
1132: throws CompilerException {
1133: if (DEBUG)
1134: System.out.print("\nCompile App: " + args
1135: + ", valueList = " + valueList);
1136:
1137: if (args == f_lisp.NIL)
1138: return f_lisp.makeCons(machine.NIL, code);
1139: else
1140: return compile(args.car(), valueList, compileApp(machine,
1141: args.cdr(), valueList, f_lisp.makeCons(
1142: new ConsPrimitive(f_lisp), code)));
1143: }
1144:
1145: // ##JPG added
1146: // similar to compileApp() but doesn't evaluate parameters
1147: LispValue compileAppConstant(SECDMachine machine, LispValue args,
1148: LispValue valueList, LispValue code)
1149: throws CompilerException {
1150: if (DEBUG)
1151: System.out
1152: .print("\nCompile AppConstant: " + args
1153: + ", valueList = " + valueList
1154: + ", code = " + code);
1155:
1156: if (args == f_lisp.NIL)
1157: return f_lisp.makeCons(machine.NIL, code);
1158: else
1159: return f_lisp.makeCons(machine.LDC, f_lisp.makeCons(args
1160: .car(), compileAppConstant(machine, args.cdr(),
1161: valueList, f_lisp.makeCons(
1162: new ConsPrimitive(f_lisp), code))));
1163: }
1164:
1165: LispValue compileBuiltin(SECDMachine machine, LispValue fn,
1166: LispValue args, LispValue valueList, LispValue code)
1167: throws CompilerException {
1168: if (DEBUG)
1169: System.out.print("\nCompile Builtin: " + fn + " " + args);
1170:
1171: // Builtin LISP primitives have a symbol-function of the
1172: // form (:PRIMITIVE <ic>). We call the CompileArgs functions
1173: // of the primitive instruction.
1174: LispValue executableCode = null;
1175:
1176: if (fn.basic_atom())
1177: executableCode = ((LispFunction) fn.symbol_function())
1178: .getCode().second();
1179: else if (fn.basic_functionp())
1180: executableCode = (((LispFunction) fn).getCode()).second();
1181:
1182: if (!((LispPrimitive) executableCode).validArgumentList(args))
1183: throw new ArgumentCountMismatchException(((LispString) fn
1184: .symbol_name()).getValue(),
1185: ((LispPrimitive) executableCode)
1186: .parameterCountString(),
1187: ((LispInteger) (args.length())).getLongValue());
1188:
1189: return ((LispPrimitive) executableCode).CompileArgs(this ,
1190: machine, fn, args, valueList, code);
1191: }
1192:
1193: /**
1194: * FN is an instance of StandardLispFunction
1195: * @param machine
1196: * @param fn an instance of StandardLispFunction
1197: * @param args
1198: * @param valueList
1199: * @param code
1200: * @throws CompilerException
1201: */
1202: LispValue compileUserDefinedFunction(SECDMachine machine,
1203: LispValue fn, LispValue args, LispValue valueList,
1204: LispValue code) throws CompilerException {
1205: if (DEBUG)
1206: System.out.print("\nCompile user-defined: (" + fn + " "
1207: + args + "), vl = " + valueList);
1208:
1209: LispValue executableCode = ((LispFunction) fn).getCode();
1210:
1211: // Assume that the arguments are correct ?
1212: // TODO: how do we check arguments? Besides, we've lost the name of the function.
1213: /*
1214: if (!((LispPrimitive)(executableCode.second())).validArgumentList(args))
1215: throw new ArgumentCountMismatchException(((LispString)fn.symbol_name()).getValue(),
1216: ((LispPrimitive)(executableCode.second())).parameterCountString(),
1217: ((LispInteger)(args.length())).getLongValue());
1218: */
1219:
1220: return compileArgsLeftToRight(args, valueList, executableCode
1221: .append(code));
1222: }
1223:
1224: LispValue compileAnd(SECDMachine machine, LispValue args,
1225: LispValue valueList, LispValue code)
1226: throws CompilerException {
1227: // No args: return default value of T
1228: if (args == f_lisp.NIL)
1229: return f_lisp.makeCons(machine.T, code);
1230:
1231: // 1 arg: just compile the argument.
1232: if (args.cdr() == f_lisp.NIL)
1233: return compile(args.first(), valueList, code);
1234:
1235: // Multiple arguments: construct an IF statement
1236: // (let ((*dummy* args.first())) (if ...))
1237:
1238: LispValue dummyVar = f_lisp.EVAL.intern("*AND-DUMMY-VAR*");
1239: dummyVar.set_special(true);
1240:
1241: return compile(f_lisp.makeList(LET, f_lisp.makeCons(f_lisp
1242: .makeList(dummyVar, args.first()), f_lisp.NIL), f_lisp
1243: .makeList(IF, dummyVar, compileAndAux(dummyVar, args
1244: .cdr()), f_lisp.NIL)), valueList, code);
1245: }
1246:
1247: LispValue compileAndAux(LispValue dummyVar, LispValue args) {
1248: if (args.cdr() == f_lisp.NIL)
1249: return (args.car());
1250:
1251: return f_lisp.makeList(PROGN, f_lisp.makeList(SETQ, dummyVar,
1252: args.car()), f_lisp.makeList(IF, dummyVar,
1253: compileAndAux(dummyVar, args.cdr()), f_lisp.NIL));
1254: }
1255:
1256: LispValue compileOr(SECDMachine machine, LispValue args,
1257: LispValue valueList, LispValue code)
1258: throws CompilerException {
1259: // No args: return default value of NIL
1260: if (args == f_lisp.NIL)
1261: return f_lisp.makeCons(machine.NIL, code);
1262:
1263: // 1 arg: just compile the argument.
1264: if (args.cdr() == f_lisp.NIL)
1265: return compile(args.first(), valueList, code);
1266:
1267: // Multiple arguments: construct an IF statement
1268: // (let ((*dummy* args.first())) (if ...))
1269:
1270: LispValue dummyVar = f_lisp.EVAL.intern("*OR-DUMMY-VAR*");
1271: dummyVar.set_special(true);
1272:
1273: return compile(f_lisp.makeList(LET, f_lisp.makeCons(f_lisp
1274: .makeList(dummyVar, args.first()), f_lisp.NIL), f_lisp
1275: .makeList(IF, dummyVar, dummyVar, compileOrAux(
1276: dummyVar, args.cdr()))), valueList, code);
1277: }
1278:
1279: LispValue compileOrAux(LispValue dummyVar, LispValue args) {
1280: if (args.cdr() == f_lisp.NIL)
1281: return (args.car());
1282:
1283: return f_lisp.makeList(PROGN, f_lisp.makeList(SETQ, dummyVar,
1284: args.car()), f_lisp.makeList(IF, dummyVar, dummyVar,
1285: compileOrAux(dummyVar, args.cdr())));
1286: }
1287:
1288: LispValue compileDefun(SECDMachine machine, LispValue name,
1289: LispValue argsAndBody, LispValue valueList, LispValue code)
1290: throws CompilerException {
1291: // Change the DEFUN into a LAMBDA and compile it.
1292: //##JPG
1293: // for compilation of recursive functions, we need to know if the symbol under compilation is a
1294: // function or a macro. It's the aim of DUMMY_FUNCTION
1295: name.setf_symbol_function(DUMMY_FUNCTION);
1296:
1297: // OB:
1298: // Added support for documentation strings on defuns.
1299: // Todo, fix support, so that DECLARE statements are ignored.
1300: // If the body of the function only consists of a string, this is not taken as a
1301: // documentation string, as there would be no content of the function otherwise.
1302: final LispValue possibleDocumentation = argsAndBody.second();
1303: LispValue endArgsAndBody = argsAndBody;
1304: if (possibleDocumentation instanceof LispString
1305: && argsAndBody.basic_length() > 2) {
1306: name.setf_documentation(f_lisp.EVAL.intern("FUNCTION"),
1307: possibleDocumentation);
1308: endArgsAndBody = f_lisp.makeCons(argsAndBody.car(),
1309: argsAndBody.cdr().cdr());
1310: }
1311: // Adds an implicit BLOCK with the same name as the defun around the definition.
1312: endArgsAndBody = f_lisp.makeList(endArgsAndBody.car(), f_lisp
1313: .makeCons(f_lisp.getEval().intern("BLOCK"), f_lisp
1314: .makeCons(name, endArgsAndBody.cdr())));
1315: name.setf_symbol_function(compileList(
1316: f_lisp.MACHINE,
1317: f_lisp.makeCons(LAMBDA, endArgsAndBody),
1318: f_lisp.makeCons(f_lisp.makeCons(name, f_lisp.NIL),
1319: valueList),
1320: f_lisp.makeCons(machine.STOP, f_lisp.NIL)).second());
1321:
1322: return compileList(f_lisp.MACHINE, f_lisp.makeCons(QUOTE,
1323: f_lisp.makeCons(name, f_lisp.NIL)), f_lisp.makeCons(
1324: f_lisp.makeCons(name, f_lisp.NIL), valueList), code);
1325: }
1326:
1327: //##JPG method added, compile DEFMACRO, April 2005
1328: //
1329: LispValue compileDefmacro(SECDMachine machine, LispValue name,
1330: LispValue argsAndBody, LispValue valueList, LispValue code)
1331: throws CompilerException {
1332: LispValue tempNew = f_lisp.EVAL.intern("%%%"
1333: + name.symbol_name().toStringSimple(),
1334: (LispPackage) f_lisp.findPackage("SYSTEM"));
1335: compileDefun(machine, tempNew, argsAndBody, valueList, code); // TODO, fix an ew method for doing this.
1336: // ##JPG
1337: // for compilation of recursive macros, we need to know if the symbol under compilation is a
1338: // function or a macro. It's the aim of DUMMY_FUNCTION
1339: name.setf_symbol_function(DUMMY_MACRO);
1340:
1341: // todo: Figure out how to imbed BACKQUOTE in the compiler.
1342: //##JPG MACRO keyword if added in front of code to signal this code is a macro
1343: // setf_symbol_function() has been modified to detect this keyword
1344: //LispValue args = argsAndBody.first();
1345: //LispValue body = argsAndBody.second();
1346: //LispValue expandedBody = f_lisp.NIL;
1347: //if (body.first().eq(f_lisp.BACKQUOTE) != f_lisp.NIL)
1348: // expandedBody = f_lisp.backquote(body.second());
1349: // else
1350: // expandedBody = body;
1351:
1352: // OB:
1353: // Added support for documentation strings on defmacros.
1354: // Todo, fix support, so that DECLARE statements are ignored.
1355: // If the body of the macro only consists of a string, this is not taken as a
1356: // documentation string, as there would be no content of the macro otherwise.
1357: final LispValue possibleDocumentation = argsAndBody.second();
1358: LispValue endArgsAndBody = argsAndBody;
1359: if (possibleDocumentation instanceof LispString
1360: && argsAndBody.basic_length() > 2) {
1361: name.setf_documentation(f_lisp.EVAL.intern("FUNCTION"),
1362: possibleDocumentation);
1363: endArgsAndBody = f_lisp.makeCons(argsAndBody.car(),
1364: argsAndBody.cdr().cdr());
1365: }
1366:
1367: name.setf_symbol_function(f_lisp.makeCons(MACRO, compileList(
1368: f_lisp.MACHINE,
1369: f_lisp.makeCons(LAMBDA, endArgsAndBody), // f_lisp.makeList(args, expandedBody)),
1370: f_lisp.makeCons(f_lisp.makeCons(name, f_lisp.NIL),
1371: valueList),
1372: f_lisp.makeCons(machine.STOP, f_lisp.NIL)).second()));
1373:
1374: return compileList(f_lisp.MACHINE, f_lisp.makeCons(QUOTE,
1375: f_lisp.makeCons(name, f_lisp.NIL)), f_lisp.makeCons(
1376: f_lisp.makeCons(name, f_lisp.NIL), valueList), code);
1377: }
1378:
1379: // Optimization, 15 April 97, p. 174 of Kogge.
1380: // SEL followed by RTN can be optimized to do a RTN
1381: // at the end of each branch and eliminate the final RTN.
1382:
1383: LispValue compileIf(SECDMachine machine, LispValue test,
1384: LispValue thenExpr, LispValue elseExpr,
1385: LispValue valueList, LispValue code)
1386: throws CompilerException {
1387: if ((code.car() == machine.RTN) || (code.car() == machine.STOP))
1388: return compileOptimizedIf(machine, test, thenExpr,
1389: elseExpr, valueList, code);
1390: else
1391: return compile(test, valueList, f_lisp.makeCons(
1392: machine.SEL, f_lisp.makeCons(compile(thenExpr,
1393: valueList, f_lisp.makeCons(machine.JOIN,
1394: f_lisp.NIL)), f_lisp
1395: .makeCons(compile(elseExpr, valueList,
1396: f_lisp.makeCons(machine.JOIN,
1397: f_lisp.NIL)), code))));
1398: }
1399:
1400: LispValue compileOptimizedIf(SECDMachine machine, LispValue test,
1401: LispValue thenExpr, LispValue elseExpr,
1402: LispValue valueList, LispValue code)
1403: // Remove final RTN and optimize by putting RTN in branches.
1404: throws CompilerException
1405:
1406: {
1407: return compile(test, valueList, f_lisp.makeCons(machine.TEST,
1408: f_lisp.makeCons(compile(thenExpr, valueList, f_lisp
1409: .makeCons(code.car(), f_lisp.NIL)), compile(
1410: elseExpr, valueList, code))));
1411: }
1412:
1413: LispValue compileProgn(LispValue body, LispValue valueList,
1414: LispValue code) throws CompilerException {
1415: if (body == f_lisp.NIL)
1416: return code;
1417: else
1418: return compile(body.car(), valueList, compileProgn(body
1419: .cdr(), valueList, code));
1420: }
1421:
1422: /*
1423: private java.util.Map blocks = new java.util.HashMap();
1424:
1425: LispValue compileBlock(final SECDMachine machine, final LispValue body, final LispValue valueList, final LispValue code) throws CompilerException {
1426: System.err.println("We have a block");
1427: final LispValue tag = body.car();
1428: System.err.println("Tag " + tag);
1429: java.util.Stack stBlock = (java.util.Stack)blocks.get(tag);
1430: if(null == stBlock) {
1431: System.err.println("Creating new stack for this tag");
1432: stBlock = new java.util.Stack();
1433: blocks.put(tag,stBlock);
1434: }
1435: final LispValue uhm = f_lisp.makeList(machine.S.value(),machine.E.value(),machine.C.value(),machine.D.value());
1436: stBlock.push(uhm);
1437: final int size = stBlock.size();
1438: final LispValue rest = f_lisp.makeCons(PROGN,body.cdr());
1439: final LispValue afterC = compile(machine,rest,valueList);
1440: System.err.println("After compilation");
1441: if(stBlock.size() == size) {
1442: System.err.println("Popping block");
1443: System.err.println(stBlock.pop());
1444: }
1445: return afterC;
1446: }
1447: */
1448:
1449: LispValue compileLambda(SECDMachine machine, LispValue body,
1450: LispValue valueList, LispValue code)
1451: throws CompilerException {
1452: // System.out.print("\nCompile Lambda: "); body.prin1();
1453: // System.out.print("\n code = "); code.prin1();
1454: return f_lisp.makeCons(machine.LDF, f_lisp.makeCons(compile(
1455: body, valueList, f_lisp.makeCons(machine.RTN,
1456: f_lisp.NIL)), code));
1457: }
1458:
1459: /**
1460: * Send in either code or a symbol with a function value.
1461: * Returns true only if the first element of the code list
1462: * is :PRIMITIVE.
1463: * @param code a LISP list.
1464: * @return true if the code indicates a built-in function
1465: */
1466: public static boolean isBuiltinFunction(LispValue code) {
1467: if ((code.basic_symbolp())
1468: && (code.fboundp() == code.getLisp().T))
1469: code = code.symbol_function();
1470:
1471: if ((code == null) || (code == code.getLisp().NIL))
1472: return false;
1473:
1474: if (code.basic_functionp())
1475: code = ((LispFunction) code).getCode();
1476:
1477: return (code.basic_listp() && (code.first() == code.getLisp().EVAL
1478: .intern("PRIMITIVE", (LispPackage) (code.getLisp()
1479: .findPackage("KEYWORD")))));
1480: }
1481:
1482: // Contributed by Jean-Pierre Gaillardon, April 2005
1483: /**
1484: * @param code a Lisp list
1485: * @return true if code is code for a macro (the first element is :MACRO)
1486: */
1487: public boolean isMacroCode(LispValue code) {
1488: return code.basic_listp() && (code.car() == MACRO);
1489: }
1490:
1491: }
|