001: /*
002: * Jatha - a Common LISP-compatible LISP library in Java.
003: * Copyright (C) 1997-2005 Micheal Scott Hewett
004: *
005: * This library is free software; you can redistribute it and/or
006: * modify it under the terms of the GNU Lesser General Public
007: * License as published by the Free Software Foundation; either
008: * version 2.1 of the License, or (at your option) any later version.
009: *
010: * This library is distributed in the hope that it will be useful,
011: * but WITHOUT ANY WARRANTY; without even the implied warranty of
012: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
013: * Lesser General Public License for more details.
014: *
015: * You should have received a copy of the GNU Lesser General Public
016: * License along with this library; if not, write to the Free Software
017: * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
018: *
019: *
020: * For further information, please contact Micheal Hewett at
021: * hewett@cs.stanford.edu
022: *
023: */
024:
025: package org.jatha.machine;
026:
027: import org.jatha.Jatha;
028: import org.jatha.dynatype.*;
029: import org.jatha.compile.*;
030:
031: // @date Sat Feb 1 21:04:49 1997
032: /**
033: * The SECDMachine contains the registers and
034: * basic functionality of the SECD machine.
035: * It exports constants corresponding to each
036: * primitive machine instruction and to each
037: * primitive LISP operation, so that the compiler
038: * may insert them into code.
039: *
040: * A modification to the standard SECD machine is
041: * the new 'B' register that handles dynamic
042: * binding.
043: *
044: * @see SECDop
045: * @author Micheal S. Hewett hewett@cs.stanford.edu
046: */
047: public class SECDMachine // extends Abstract Machine !
048: {
049:
050: Jatha f_lisp = null;
051:
052: private static boolean DEBUG = false;
053:
054: // ------ Registers --------------
055:
056: public SECDRegister S = null; // Random names nobody will accidentally use
057: public SECDRegister E = null; // These should be protected from user change.
058: public SECDRegister C = null;
059: public SECDRegister D = null;
060: // The B register is for dynamic bindings. It contains a hash table
061: // that indexes on symbol name. The value is a list of values,
062: // the most recent value at the front of the list.
063: //
064: // There is a B register for each machine so that it will
065: // function correctly in a multi-threaded environment.
066: public LispValue B = null;
067:
068: // A X register for dumping tag information, as a stack. This is the same register as D, but not totally. =)
069: public SECDRegister X = null;
070:
071: /* ------------------ BASIC MACHINE OPS ------------------------------ */
072:
073: public SECDop AP = null;
074: public SECDop BLK = null; //OB: new opcode June 2005
075: public SECDop DAP = null;
076: public SECDop DUM = null;
077: public SECDop JOIN = null;
078: public SECDop LD = null;
079: public SECDop LD_GLOBAL = null;
080: public SECDop LDC = null;
081: public SECDop LDF = null;
082: public SECDop LDFC = null;
083: public SECDop LDR = null; //##JPG new opcode April 2005
084: public SECDop LIS = null;
085: public SECDop NIL = null;
086: public SECDop RAP = null;
087: public SECDop RTN = null;
088: public SECDop RTN_IF = null;
089: public SECDop RTN_IT = null;
090: public SECDop SEL = null;
091: public SECDop SP_BIND = null;
092: public SECDop SP_UNBIND = null;
093: public SECDop STOP = null;
094: public SECDop T = null;
095: public SECDop TAG_B = null;
096: public SECDop TAG_E = null;
097: public SECDop TEST = null;
098:
099: public SECDMachine(Jatha lisp) {
100: f_lisp = lisp;
101:
102: S = new SECDRegister(f_lisp, "S-05171955"); // Random names nobody will accidentally use
103: E = new SECDRegister(f_lisp, "E-06141957"); // These should be protected from user change.
104: C = new SECDRegister(f_lisp, "C-06151962");
105: D = new SECDRegister(f_lisp, "D-06071966");
106: X = new SECDRegister(f_lisp, "X-02324255");
107: B = new StandardLispHashTable(f_lisp, f_lisp.NIL, f_lisp.NIL,
108: f_lisp.NIL, f_lisp.NIL);
109: AP = new opAP(f_lisp);
110: BLK = new opBLK(f_lisp);
111: DAP = new opDAP(f_lisp);
112: DUM = new opDUM(f_lisp);
113: JOIN = new opJOIN(f_lisp);
114: LD = new opLD(f_lisp);
115: LD_GLOBAL = new opLD_GLOBAL(f_lisp);
116: LDC = new opLDC(f_lisp);
117: LDF = new opLDF(f_lisp);
118: LDFC = new opLDFC(f_lisp);
119: LDR = new opLDR(f_lisp); //##JPG init new opcode LDR April 2005
120: LIS = new opLIS(f_lisp);
121: NIL = new opNIL(f_lisp);
122: RAP = new opRAP(f_lisp);
123: RTN = new opRTN(f_lisp);
124: RTN_IF = new opRTN_IF(f_lisp);
125: RTN_IT = new opRTN_IT(f_lisp);
126: SEL = new opSEL(f_lisp);
127: SP_BIND = new opSP_BIND(f_lisp);
128: SP_UNBIND = new opSP_UNBIND(f_lisp);
129: STOP = new opSTOP(f_lisp);
130: T = new opT(f_lisp);
131: TAG_B = new opTAG_B(f_lisp);
132: TAG_E = new opTAG_E(f_lisp);
133: TEST = new opTEST(f_lisp);
134:
135: }
136:
137: public Jatha getLisp() {
138: return f_lisp;
139: }
140:
141: /* ------------------ SPECIAL BINDING ------------------------------ */
142:
143: // Assume the caller has verified that this is a special variable.
144: public void special_bind(LispValue symbol, LispValue value) {
145: // System.err.println("Special bind called on: " + symbol);
146:
147: if (symbol.basic_constantp()) {
148: // Cause a LispConstant Redefined error
149: symbol.setf_symbol_value(value);
150: } else {
151: LispValue bindings = B.gethash(symbol, f_lisp.NIL);
152:
153: B.setf_gethash(symbol, f_lisp.makeCons(value, bindings));
154: symbol.adjustSpecialCount(+1);
155: }
156: }
157:
158: public void special_unbind(LispValue symbol) {
159: LispValue bindings = B.gethash(symbol, f_lisp.NIL);
160:
161: // System.err.println("Special unbind called on: " + symbol);
162:
163: B.setf_gethash(symbol, bindings.cdr());
164: symbol.adjustSpecialCount(-1);
165: }
166:
167: // Sets the binding of a special variable.
168: public void special_set(LispValue symbol, LispValue value) {
169: if (symbol.get_specialCount() > 0) {
170: LispValue bindings = B.gethash(symbol, f_lisp.NIL);
171: B.setf_gethash(symbol, f_lisp.makeCons(value, bindings
172: .cdr()));
173: } else
174: symbol.setf_symbol_value(value);
175: }
176:
177: // Assume the caller has verified that this is a special variable.
178: public LispValue get_special_value(LispValue symbol) {
179: // System.err.println("specialCount of " + symbol + " is " + symbol.get_specialCount());
180:
181: if (symbol.get_specialCount() > 0)
182: return B.gethash(symbol).car();
183: else
184: return symbol.symbol_value();
185: }
186:
187: public LispValue Execute(LispValue code, LispValue globals)
188: throws CompilerException {
189: LispValue opcode;
190:
191: // System.out.print("\nExecuting code: ");
192: // code.prin1();
193:
194: S.assign(f_lisp.NIL);
195: E.assign(globals);
196: C.assign(code);
197: D.assign(f_lisp.NIL);
198:
199: opcode = C.value().car();
200:
201: while ((opcode != STOP) && (opcode != f_lisp.NIL)) {
202: if (DEBUG) {
203: // Test output.
204: //
205: System.out.print("\n S: " + S.value());
206: System.out.print("\n E: " + E.value());
207: System.out.print("\n C: " + C.value());
208: System.out.print("\n D: " + D.value());
209: // System.out.print(" of class " + opcode.getClass().getName());
210: System.out.print("\n" + opcode); // Testing
211: System.out.flush();
212: }
213:
214: if (opcode != null)
215: ((LispPrimitive) opcode).Execute(this );
216: else {
217: System.err
218: .println("internal error in Jatha.SECDMachine.Execute: opcode is null");
219: System.err.println("remaining code is "
220: + C.value().toString());
221: }
222:
223: try {
224: opcode = C.value().car(); // Each opcode pops the C register as necessary
225: } catch (Exception e) {
226: e.printStackTrace();
227: System.err.print("\n S: " + S.value());
228: System.err.print("\n E: " + E.value());
229: System.err.print("\n C: " + C.value());
230: System.err.print("\n D: " + D.value());
231: // System.out.print(" of class " + opcode.getClass().getName());
232: System.err.print("\n" + opcode); // Testing
233: System.err.flush();
234:
235: opcode = f_lisp.NIL;
236: }
237: }
238:
239: return S.value().car(); // Top value on Stack is the return value.
240: }
241:
242: public void setStackValue(SECDRegister e, LispValue val) {
243: }
244: } // End of class SECDMachine.
|