001: /*
002: * SpecialOperators.java
003: *
004: * Copyright (C) 2003 Peter Graves
005: * $Id: SpecialOperators.java,v 1.8 2003/11/15 11:03:32 beedlem Exp $
006: *
007: * This program is free software; you can redistribute it and/or
008: * modify it under the terms of the GNU General Public License
009: * as published by the Free Software Foundation; either version 2
010: * of the License, or (at your option) any later version.
011: *
012: * This program is distributed in the hope that it will be useful,
013: * but WITHOUT ANY WARRANTY; without even the implied warranty of
014: * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
015: * GNU General Public License for more details.
016: *
017: * You should have received a copy of the GNU General Public License
018: * along with this program; if not, write to the Free Software
019: * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
020: */
021:
022: package org.armedbear.lisp;
023:
024: public final class SpecialOperators extends Lisp {
025: // ### quote
026: private static final SpecialOperator QUOTE = new SpecialOperator(
027: "quote") {
028: public LispObject execute(LispObject args, Environment env)
029: throws ConditionThrowable {
030: return args.car();
031: }
032: };
033:
034: // ### if
035: private static final SpecialOperator IF = new SpecialOperator("if") {
036: public LispObject execute(LispObject args, Environment env)
037: throws ConditionThrowable {
038: final LispThread thread = LispThread.currentThread();
039: switch (args.length()) {
040: case 2: {
041: if (eval(args.car(), env, thread) != NIL)
042: return eval(args.cadr(), env, thread);
043: return NIL;
044: }
045: case 3: {
046: if (eval(args.car(), env, thread) != NIL)
047: return eval(args.cadr(), env, thread);
048: return eval(args.cdr().cadr(), env, thread);
049: }
050: default:
051: throw new ConditionThrowable(
052: new WrongNumberOfArgumentsException("IF"));
053: }
054: }
055: };
056:
057: // ### let
058: private static final SpecialOperator LET = new SpecialOperator(
059: "let") {
060: public LispObject execute(LispObject args, Environment env)
061: throws ConditionThrowable {
062: return _let(args, env, false);
063: }
064: };
065:
066: // ### let*
067: private static final SpecialOperator LETX = new SpecialOperator(
068: "let*") {
069: public LispObject execute(LispObject args, Environment env)
070: throws ConditionThrowable {
071: return _let(args, env, true);
072: }
073: };
074:
075: private static final LispObject _let(LispObject args,
076: Environment env, boolean sequential)
077: throws ConditionThrowable {
078: LispObject varList = checkList(args.car());
079: final LispThread thread = LispThread.currentThread();
080: LispObject result = NIL;
081: if (varList != NIL) {
082: Environment oldDynEnv = thread.getDynamicEnvironment();
083: try {
084: Environment ext = new Environment(env);
085: Environment evalEnv = sequential ? ext : env;
086: for (int i = varList.length(); i-- > 0;) {
087: LispObject obj = varList.car();
088: varList = varList.cdr();
089: if (obj instanceof Cons) {
090: bind(checkSymbol(obj.car()), eval(obj.cadr(),
091: evalEnv, thread), ext);
092: } else
093: bind(checkSymbol(obj), NIL, ext);
094: }
095: LispObject body = args.cdr();
096: while (body != NIL) {
097: result = eval(body.car(), ext, thread);
098: body = body.cdr();
099: }
100: } finally {
101: thread.setDynamicEnvironment(oldDynEnv);
102: }
103: } else {
104: LispObject body = args.cdr();
105: while (body != NIL) {
106: result = eval(body.car(), env, thread);
107: body = body.cdr();
108: }
109: }
110: return result;
111: }
112:
113: // ### symbol-macrolet
114: private static final SpecialOperator SYMBOL_MACROLET = new SpecialOperator(
115: "symbol-macrolet") {
116: public LispObject execute(LispObject args, Environment env)
117: throws ConditionThrowable {
118: boolean sequential = true; // FIXME Is this right?
119: LispObject varList = checkList(args.car());
120: final LispThread thread = LispThread.currentThread();
121: LispObject result = NIL;
122: if (varList != NIL) {
123: Environment oldDynEnv = thread.getDynamicEnvironment();
124: try {
125: Environment ext = new Environment(env);
126: Environment evalEnv = sequential ? ext : env;
127: for (int i = varList.length(); i-- > 0;) {
128: LispObject obj = varList.car();
129: varList = varList.cdr();
130: if (obj instanceof Cons && obj.length() == 2) {
131: bind(checkSymbol(obj.car()),
132: // new SymbolMacro(eval(obj.cadr(), evalEnv, thread)),
133: new SymbolMacro(obj.cadr()), ext);
134: } else
135: throw new ConditionThrowable(
136: new ProgramError(
137: "SYMBOL-MACROLET: bad symbol-expansion pair: "
138: + obj));
139: }
140: LispObject body = args.cdr();
141: while (body != NIL) {
142: result = eval(body.car(), ext, thread);
143: body = body.cdr();
144: }
145: } finally {
146: thread.setDynamicEnvironment(oldDynEnv);
147: }
148: } else {
149: LispObject body = args.cdr();
150: while (body != NIL) {
151: result = eval(body.car(), env, thread);
152: body = body.cdr();
153: }
154: }
155: return result;
156: }
157: };
158:
159: // ### load-time-value
160: // load-time-value form &optional read-only-p => object
161: private static final SpecialOperator LOAD_TIME_VALUE = new SpecialOperator(
162: "load-time-value") {
163: public LispObject execute(LispObject args, Environment env)
164: throws ConditionThrowable {
165: switch (args.length()) {
166: case 1:
167: case 2:
168: return eval(args.car(), new Environment(), LispThread
169: .currentThread());
170: default:
171: throw new ConditionThrowable(
172: new WrongNumberOfArgumentsException(this ));
173: }
174: }
175: };
176:
177: // ### locally
178: private static final SpecialOperator LOCALLY = new SpecialOperator(
179: "locally") {
180: public LispObject execute(LispObject args, Environment env)
181: throws ConditionThrowable {
182: LispThread thread = LispThread.currentThread();
183: while (args != NIL) {
184: LispObject obj = args.car();
185: if (obj instanceof Cons && obj.car() == Symbol.DECLARE)
186: ; // FIXME
187: else
188: break;
189: args = args.cdr();
190: }
191: LispObject result = NIL;
192: while (args != NIL) {
193: result = eval(args.car(), env, thread);
194: args = args.cdr();
195: }
196: return result;
197: }
198: };
199:
200: // ### progn
201: private static final SpecialOperator PROGN = new SpecialOperator(
202: "progn") {
203: public LispObject execute(LispObject args, Environment env)
204: throws ConditionThrowable {
205: LispThread thread = LispThread.currentThread();
206: LispObject result = NIL;
207: while (args != NIL) {
208: result = eval(args.car(), env, thread);
209: args = args.cdr();
210: }
211: return result;
212: }
213: };
214:
215: private static final SpecialOperator FLET = new SpecialOperator(
216: "flet") {
217: public LispObject execute(LispObject args, Environment env)
218: throws ConditionThrowable {
219: return _flet(args, env, false);
220: }
221: };
222:
223: private static final SpecialOperator LABELS = new SpecialOperator(
224: "labels") {
225: public LispObject execute(LispObject args, Environment env)
226: throws ConditionThrowable {
227: return _flet(args, env, true);
228: }
229: };
230:
231: private static final LispObject _flet(LispObject args,
232: Environment env, boolean recursive)
233: throws ConditionThrowable {
234: // First argument is a list of local function definitions.
235: LispObject defs = checkList(args.car());
236: final LispThread thread = LispThread.currentThread();
237: LispObject result;
238: if (defs != NIL) {
239: Environment oldDynEnv = thread.getDynamicEnvironment();
240: Environment ext = new Environment(env);
241: while (defs != NIL) {
242: LispObject def = checkList(defs.car());
243: Symbol symbol = checkSymbol(def.car());
244: LispObject rest = def.cdr();
245: LispObject parameters = rest.car();
246: LispObject body = rest.cdr();
247: body = new Cons(symbol, body);
248: body = new Cons(Symbol.BLOCK, body);
249: body = new Cons(body, NIL);
250: Closure closure;
251: if (recursive)
252: closure = new Closure(parameters, body, ext);
253: else
254: closure = new Closure(parameters, body, env);
255: closure.setLambdaName(list2(Symbol.FLET, symbol));
256: ext.bindFunctional(symbol, closure);
257: defs = defs.cdr();
258: }
259: result = progn(args.cdr(), ext, thread);
260: thread.setDynamicEnvironment(oldDynEnv);
261: } else
262: result = progn(args.cdr(), env, thread);
263: return result;
264: }
265:
266: // ### the
267: // the value-type form => result*
268: private static final SpecialOperator THE = new SpecialOperator(
269: "the") {
270: public LispObject execute(LispObject args, Environment env)
271: throws ConditionThrowable {
272: if (args.length() != 2)
273: throw new ConditionThrowable(
274: new WrongNumberOfArgumentsException(this ));
275: return eval(args.cadr(), env, LispThread.currentThread());
276: }
277: };
278:
279: // ### progv
280: private static final SpecialOperator PROGV = new SpecialOperator(
281: "progv") {
282: public LispObject execute(LispObject args, Environment env)
283: throws ConditionThrowable {
284: if (args.length() < 2)
285: throw new ConditionThrowable(
286: new WrongNumberOfArgumentsException(this ));
287: final LispThread thread = LispThread.currentThread();
288: final LispObject symbols = checkList(eval(args.car(), env,
289: thread));
290: LispObject values = checkList(eval(args.cadr(), env, thread));
291: // Save current values of symbols.
292: final LispObject[] oldValues = new LispObject[symbols
293: .length()];
294: int i = 0;
295: for (LispObject list = symbols; list != NIL; list = list
296: .cdr()) {
297: LispObject symbol = list.car();
298: oldValues[i++] = symbol.getSymbolValue();
299: }
300: Environment oldDynEnv = thread.getDynamicEnvironment();
301: try {
302: // Set up the new bindings.
303: for (LispObject list = symbols; list != NIL; list = list
304: .cdr()) {
305: Symbol symbol = checkSymbol(list.car());
306: LispObject value;
307: if (values != NIL) {
308: value = values.car();
309: values = values.cdr();
310: } else
311: value = null;
312: if (symbol.isSpecialVariable())
313: thread.bindSpecial(symbol, value);
314: else
315: symbol.setSymbolValue(value);
316: }
317: // Implicit PROGN.
318: LispObject result = NIL;
319: LispObject body = args.cdr().cdr();
320: while (body != NIL) {
321: result = eval(body.car(), env, thread);
322: body = body.cdr();
323: }
324: return result;
325: } finally {
326: thread.setDynamicEnvironment(oldDynEnv);
327: // Undo bindings.
328: i = 0;
329: for (LispObject list = symbols; list != NIL; list = list
330: .cdr()) {
331: Symbol symbol = (Symbol) list.car();
332: symbol.setSymbolValue(oldValues[i]);
333: }
334: }
335: }
336: };
337:
338: // ### declare
339: private static final SpecialOperator DECLARE = new SpecialOperator(
340: "declare") {
341: public LispObject execute(LispObject args, Environment env) {
342: return NIL;
343: }
344: };
345:
346: // ### function
347: private static final SpecialOperator FUNCTION = new SpecialOperator(
348: "function") {
349: public LispObject execute(LispObject args, Environment env)
350: throws ConditionThrowable {
351: final LispObject arg = args.car();
352: if (arg instanceof Symbol) {
353: LispObject functional = env.lookupFunctional(arg);
354: if (functional instanceof Autoload) {
355: Autoload autoload = (Autoload) functional;
356: autoload.load();
357: functional = autoload.getSymbol()
358: .getSymbolFunction();
359: }
360: if (functional instanceof Function)
361: return functional;
362: if (functional instanceof GenericFunction)
363: return functional;
364: throw new ConditionThrowable(new UndefinedFunction(arg));
365: }
366: if (arg instanceof Cons) {
367: if (arg.car() == Symbol.LAMBDA)
368: return new Closure(arg.cadr(), arg.cddr(), env);
369: if (arg.car() == Symbol.SETF) {
370: LispObject f = get(checkSymbol(arg.cadr()),
371: PACKAGE_SYS.intern("SETF-FUNCTION"));
372: if (f != null)
373: return f;
374: }
375: }
376: throw new ConditionThrowable(new UndefinedFunction(arg));
377: }
378: };
379:
380: // ### setq
381: private static final SpecialOperator SETQ = new SpecialOperator(
382: "setq") {
383: public LispObject execute(LispObject args, Environment env)
384: throws ConditionThrowable {
385: LispObject value = Symbol.NIL;
386: final LispThread thread = LispThread.currentThread();
387: while (args != NIL) {
388: Symbol symbol = checkSymbol(args.car());
389: args = args.cdr();
390: Binding binding = null;
391: if (symbol.isSpecialVariable()) {
392: Environment dynEnv = thread.getDynamicEnvironment();
393: if (dynEnv != null)
394: binding = dynEnv.getBinding(symbol);
395: } else {
396: // Not special.
397: binding = env.getBinding(symbol);
398: }
399: if (binding != null) {
400: if (binding.value instanceof SymbolMacro) {
401: LispObject expansion = ((SymbolMacro) binding.value)
402: .getExpansion();
403: LispObject form = list3(Symbol.SETF, expansion,
404: args.car());
405: value = eval(form, env, thread);
406: } else {
407: value = eval(args.car(), env, thread);
408: binding.value = value;
409: }
410: } else {
411: if (symbol.getSymbolValue() instanceof SymbolMacro) {
412: LispObject expansion = ((SymbolMacro) symbol
413: .getSymbolValue()).getExpansion();
414: LispObject form = list3(Symbol.SETF, expansion,
415: args.car());
416: value = eval(form, env, thread);
417: } else {
418: value = eval(args.car(), env, thread);
419: symbol.setSymbolValue(value);
420: }
421: }
422: args = args.cdr();
423: }
424: // Return primary value only!
425: thread.clearValues();
426: return value;
427: }
428: };
429: }
|