001: /*
002: * SpecialOperators.java
003: *
004: * Copyright (C) 2003-2004 Peter Graves
005: * $Id: SpecialOperators.java,v 1.30 2004/09/19 17:12:01 asimon 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: import java.util.ArrayList;
025:
026: public final class SpecialOperators extends Lisp {
027: // ### quote
028: private static final SpecialOperator QUOTE = new SpecialOperator(
029: "quote", "thing") {
030: public LispObject execute(LispObject args, Environment env)
031: throws ConditionThrowable {
032: return args.car();
033: }
034: };
035:
036: // ### if
037: private static final SpecialOperator IF = new SpecialOperator("if",
038: "test then &optional else") {
039: public LispObject execute(LispObject args, Environment env)
040: throws ConditionThrowable {
041: final LispThread thread = LispThread.currentThread();
042: switch (args.length()) {
043: case 2: {
044: if (eval(args.car(), env, thread) != NIL)
045: return eval(args.cadr(), env, thread);
046: return NIL;
047: }
048: case 3: {
049: if (eval(args.car(), env, thread) != NIL)
050: return eval(args.cadr(), env, thread);
051: return eval(args.cdr().cadr(), env, thread);
052: }
053: default:
054: return signal(new WrongNumberOfArgumentsException("IF"));
055: }
056: }
057: };
058:
059: // ### let
060: private static final SpecialOperator LET = new SpecialOperator(
061: "let", "bindings &body body") {
062: public LispObject execute(LispObject args, Environment env)
063: throws ConditionThrowable {
064: return _let(args, env, false);
065: }
066: };
067:
068: // ### let*
069: private static final SpecialOperator LETX = new SpecialOperator(
070: "let*", "bindings &body body") {
071: public LispObject execute(LispObject args, Environment env)
072: throws ConditionThrowable {
073: return _let(args, env, true);
074: }
075: };
076:
077: private static final LispObject _let(LispObject args,
078: Environment env, boolean sequential)
079: throws ConditionThrowable {
080: LispObject result = NIL;
081: final LispThread thread = LispThread.currentThread();
082: final Environment oldDynEnv = thread.getDynamicEnvironment();
083: try {
084: LispObject varList = checkList(args.car());
085: LispObject body = args.cdr();
086: // Process declarations.
087: LispObject specials = NIL;
088: while (body != NIL) {
089: LispObject obj = body.car();
090: if (obj instanceof Cons && obj.car() == Symbol.DECLARE) {
091: LispObject decls = obj.cdr();
092: while (decls != NIL) {
093: LispObject decl = decls.car();
094: if (decl instanceof Cons
095: && decl.car() == Symbol.SPECIAL) {
096: LispObject vars = decl.cdr();
097: while (vars != NIL) {
098: specials = new Cons(vars.car(),
099: specials);
100: vars = vars.cdr();
101: }
102: }
103: decls = decls.cdr();
104: }
105: body = body.cdr();
106: } else
107: break;
108: }
109: Environment ext = new Environment(env);
110: if (sequential) {
111: // LET*
112: while (varList != NIL) {
113: Symbol symbol;
114: LispObject value;
115: LispObject obj = varList.car();
116: if (obj instanceof Cons) {
117: symbol = checkSymbol(obj.car());
118: value = eval(obj.cadr(), ext, thread);
119: } else {
120: symbol = checkSymbol(obj);
121: value = NIL;
122: }
123: if (specials != NIL && memq(symbol, specials)) {
124: thread.bindSpecial(symbol, value);
125: ext.declareSpecial(symbol);
126: } else if (symbol.isSpecialVariable()) {
127: thread.bindSpecial(symbol, value);
128: } else
129: ext.bind(symbol, value);
130: varList = varList.cdr();
131: }
132: } else {
133: // LET
134: final int length = varList.length();
135: LispObject[] vals = new LispObject[length];
136: for (int i = 0; i < length; i++) {
137: LispObject obj = varList.car();
138: if (obj instanceof Cons)
139: vals[i] = eval(obj.cadr(), env, thread);
140: else
141: vals[i] = NIL;
142: varList = varList.cdr();
143: }
144: varList = args.car();
145: int i = 0;
146: while (varList != NIL) {
147: Symbol symbol;
148: LispObject obj = varList.car();
149: if (obj instanceof Cons)
150: symbol = checkSymbol(obj.car());
151: else
152: symbol = checkSymbol(obj);
153: LispObject value = vals[i];
154: if (specials != NIL && memq(symbol, specials)) {
155: thread.bindSpecial(symbol, value);
156: ext.declareSpecial(symbol);
157: } else if (symbol.isSpecialVariable()) {
158: thread.bindSpecial(symbol, value);
159: } else
160: ext.bind(symbol, value);
161: varList = varList.cdr();
162: ++i;
163: }
164: }
165: while (body != NIL) {
166: result = eval(body.car(), ext, thread);
167: body = body.cdr();
168: }
169: } finally {
170: thread.setDynamicEnvironment(oldDynEnv);
171: }
172: return result;
173: }
174:
175: // ### symbol-macrolet
176: private static final SpecialOperator SYMBOL_MACROLET = new SpecialOperator(
177: "symbol-macrolet", "macrobindings &body body") {
178: public LispObject execute(LispObject args, Environment env)
179: throws ConditionThrowable {
180: boolean sequential = true; // FIXME Is this right?
181: LispObject varList = checkList(args.car());
182: final LispThread thread = LispThread.currentThread();
183: LispObject result = NIL;
184: if (varList != NIL) {
185: Environment oldDynEnv = thread.getDynamicEnvironment();
186: try {
187: Environment ext = new Environment(env);
188: Environment evalEnv = sequential ? ext : env;
189: for (int i = varList.length(); i-- > 0;) {
190: LispObject obj = varList.car();
191: varList = varList.cdr();
192: if (obj instanceof Cons && obj.length() == 2) {
193: Symbol symbol = checkSymbol(obj.car());
194: if (symbol.isSpecialVariable()) {
195: return signal(new ProgramError(
196: "Attempt to bind the special variable "
197: + symbol
198: .writeToString()
199: + " with SYMBOL-MACROLET."));
200: }
201: bind(symbol, new SymbolMacro(obj.cadr()),
202: ext);
203: } else {
204: return signal(new ProgramError(
205: "Malformed symbol-expansion pair in SYMBOL-MACROLET: "
206: + obj.writeToString()));
207: }
208: }
209: LispObject body = args.cdr();
210: while (body != NIL) {
211: result = eval(body.car(), ext, thread);
212: body = body.cdr();
213: }
214: } finally {
215: thread.setDynamicEnvironment(oldDynEnv);
216: }
217: } else {
218: LispObject body = args.cdr();
219: while (body != NIL) {
220: result = eval(body.car(), env, thread);
221: body = body.cdr();
222: }
223: }
224: return result;
225: }
226: };
227:
228: // ### load-time-value
229: // load-time-value form &optional read-only-p => object
230: private static final SpecialOperator LOAD_TIME_VALUE = new SpecialOperator(
231: "load-time-value", "form &optional read-only-p") {
232: public LispObject execute(LispObject args, Environment env)
233: throws ConditionThrowable {
234: switch (args.length()) {
235: case 1:
236: case 2:
237: return eval(args.car(), new Environment(), LispThread
238: .currentThread());
239: default:
240: return signal(new WrongNumberOfArgumentsException(this ));
241: }
242: }
243: };
244:
245: // ### locally
246: private static final SpecialOperator LOCALLY = new SpecialOperator(
247: "locally", "&body body") {
248: public LispObject execute(LispObject args, Environment env)
249: throws ConditionThrowable {
250: final LispThread thread = LispThread.currentThread();
251: final Environment ext = new Environment(env);
252: args = ext.processDeclarations(args);
253: LispObject result = NIL;
254: while (args != NIL) {
255: result = eval(args.car(), ext, thread);
256: args = args.cdr();
257: }
258: return result;
259: }
260: };
261:
262: // ### progn
263: private static final SpecialOperator PROGN = new SpecialOperator(
264: "progn", "&rest forms") {
265: public LispObject execute(LispObject args, Environment env)
266: throws ConditionThrowable {
267: LispThread thread = LispThread.currentThread();
268: LispObject result = NIL;
269: while (args != NIL) {
270: result = eval(args.car(), env, thread);
271: args = args.cdr();
272: }
273: return result;
274: }
275: };
276:
277: private static final SpecialOperator FLET = new SpecialOperator(
278: "flet", "definitions &body body") {
279: public LispObject execute(LispObject args, Environment env)
280: throws ConditionThrowable {
281: return _flet(args, env, false);
282: }
283: };
284:
285: private static final SpecialOperator LABELS = new SpecialOperator(
286: "labels", "definitions &body body") {
287: public LispObject execute(LispObject args, Environment env)
288: throws ConditionThrowable {
289: return _flet(args, env, true);
290: }
291: };
292:
293: private static final LispObject _flet(LispObject args,
294: Environment env, boolean recursive)
295: throws ConditionThrowable {
296: // First argument is a list of local function definitions.
297: LispObject defs = checkList(args.car());
298: final LispThread thread = LispThread.currentThread();
299: LispObject result;
300: if (defs != NIL) {
301: Environment oldDynEnv = thread.getDynamicEnvironment();
302: Environment ext = new Environment(env);
303: while (defs != NIL) {
304: final LispObject def = checkList(defs.car());
305: final LispObject name = def.car();
306: final Symbol symbol;
307: if (name instanceof Symbol) {
308: symbol = checkSymbol(name);
309: if (symbol.getSymbolFunction() instanceof SpecialOperator) {
310: String message = symbol.getName()
311: + " is a special operator and may not be redefined";
312: return signal(new ProgramError(message));
313: }
314: } else if (name instanceof Cons
315: && name.car() == Symbol.SETF) {
316: symbol = checkSymbol(name.cadr());
317: } else
318: return signal(new TypeError(name,
319: "valid function name"));
320: LispObject rest = def.cdr();
321: LispObject parameters = rest.car();
322: LispObject body = rest.cdr();
323: LispObject decls = NIL;
324: while (body.car() instanceof Cons
325: && body.car().car() == Symbol.DECLARE) {
326: decls = new Cons(body.car(), decls);
327: body = body.cdr();
328: }
329: body = new Cons(symbol, body);
330: body = new Cons(Symbol.BLOCK, body);
331: body = new Cons(body, NIL);
332: while (decls != NIL) {
333: body = new Cons(decls.car(), body);
334: decls = decls.cdr();
335: }
336: Closure closure;
337: if (recursive)
338: closure = new Closure(parameters, body, ext);
339: else
340: closure = new Closure(parameters, body, env);
341: closure.setLambdaName(list2(Symbol.FLET, name));
342: ext.bindFunctional(name, closure);
343: defs = defs.cdr();
344: }
345: try {
346: result = progn(args.cdr(), ext, thread);
347: } finally {
348: thread.setDynamicEnvironment(oldDynEnv);
349: }
350: } else
351: result = progn(args.cdr(), env, thread);
352: return result;
353: }
354:
355: // ### the
356: // the value-type form => result*
357: private static final SpecialOperator THE = new SpecialOperator(
358: "the", "type value") {
359: public LispObject execute(LispObject args, Environment env)
360: throws ConditionThrowable {
361: if (args.length() != 2)
362: return signal(new WrongNumberOfArgumentsException(this ));
363: return eval(args.cadr(), env, LispThread.currentThread());
364: }
365: };
366:
367: // ### progv
368: private static final SpecialOperator PROGV = new SpecialOperator(
369: "progv", "vars vals &body body") {
370: public LispObject execute(LispObject args, Environment env)
371: throws ConditionThrowable {
372: if (args.length() < 2)
373: return signal(new WrongNumberOfArgumentsException(this ));
374: final LispThread thread = LispThread.currentThread();
375: final LispObject symbols = checkList(eval(args.car(), env,
376: thread));
377: LispObject values = checkList(eval(args.cadr(), env, thread));
378: Environment oldDynEnv = thread.getDynamicEnvironment();
379: try {
380: // Set up the new bindings.
381: for (LispObject list = symbols; list != NIL; list = list
382: .cdr()) {
383: Symbol symbol = checkSymbol(list.car());
384: LispObject value;
385: if (values != NIL) {
386: value = values.car();
387: values = values.cdr();
388: } else
389: value = null;
390: thread.bindSpecial(symbol, value);
391: }
392: // Implicit PROGN.
393: LispObject result = NIL;
394: LispObject body = args.cdr().cdr();
395: while (body != NIL) {
396: result = eval(body.car(), env, thread);
397: body = body.cdr();
398: }
399: return result;
400: } finally {
401: thread.setDynamicEnvironment(oldDynEnv);
402: }
403: }
404: };
405:
406: // ### declare
407: private static final SpecialOperator DECLARE = new SpecialOperator(
408: "declare", "&rest declaration-specifiers") {
409: public LispObject execute(LispObject args, Environment env)
410: throws ConditionThrowable {
411: while (args != NIL) {
412: LispObject decl = args.car();
413: args = args.cdr();
414: if (decl instanceof Cons
415: && decl.car() == Symbol.SPECIAL) {
416: LispObject vars = decl.cdr();
417: while (vars != NIL) {
418: Symbol var = checkSymbol(vars.car());
419: env.declareSpecial(var);
420: vars = vars.cdr();
421: }
422: }
423: }
424: return NIL;
425: }
426: };
427:
428: // ### function
429: private static final SpecialOperator FUNCTION = new SpecialOperator(
430: "function", "thing") {
431: public LispObject execute(LispObject args, Environment env)
432: throws ConditionThrowable {
433: final LispObject arg = args.car();
434: if (arg instanceof Symbol) {
435: LispObject functional = env.lookupFunctional(arg);
436: if (functional instanceof Autoload) {
437: Autoload autoload = (Autoload) functional;
438: autoload.load();
439: functional = autoload.getSymbol()
440: .getSymbolFunction();
441: }
442: if (functional instanceof Function)
443: return functional;
444: if (functional instanceof GenericFunction)
445: return functional;
446: return signal(new UndefinedFunction(arg));
447: }
448: if (arg instanceof Cons) {
449: if (arg.car() == Symbol.LAMBDA)
450: return new Closure(arg.cadr(), arg.cddr(), env);
451: if (arg.car() == Symbol.SETF) {
452: LispObject f = env.lookupFunctional(arg);
453: if (f != null)
454: return f;
455: Symbol symbol = checkSymbol(arg.cadr());
456: f = get(symbol, Symbol._SETF_FUNCTION);
457: if (f != null)
458: return f;
459: f = get(symbol, PACKAGE_SYS.intern("SETF-INVERSE"));
460: if (f != null)
461: return f;
462: }
463: }
464: return signal(new UndefinedFunction(
465: list2(Keyword.NAME, arg)));
466: }
467: };
468:
469: // ### setq
470: private static final SpecialOperator SETQ = new SpecialOperator(
471: "setq", "&rest vars-and-values") {
472: public LispObject execute(LispObject args, Environment env)
473: throws ConditionThrowable {
474: LispObject value = Symbol.NIL;
475: final LispThread thread = LispThread.currentThread();
476: while (args != NIL) {
477: Symbol symbol = checkSymbol(args.car());
478: if (symbol.isConstant()) {
479: return signal(new ProgramError(symbol
480: .writeToString()
481: + " is a constant and thus cannot be set."));
482: }
483: args = args.cdr();
484: Binding binding = null;
485: if (env.isDeclaredSpecial(symbol)
486: || symbol.isSpecialVariable()) {
487: Environment dynEnv = thread.getDynamicEnvironment();
488: if (dynEnv != null)
489: binding = dynEnv.getBinding(symbol);
490: } else {
491: // Not special.
492: binding = env.getBinding(symbol);
493: }
494: if (binding != null) {
495: if (binding.value instanceof SymbolMacro) {
496: LispObject expansion = ((SymbolMacro) binding.value)
497: .getExpansion();
498: LispObject form = list3(Symbol.SETF, expansion,
499: args.car());
500: value = eval(form, env, thread);
501: } else {
502: value = eval(args.car(), env, thread);
503: binding.value = value;
504: }
505: } else {
506: if (symbol.getSymbolValue() instanceof SymbolMacro) {
507: LispObject expansion = ((SymbolMacro) symbol
508: .getSymbolValue()).getExpansion();
509: LispObject form = list3(Symbol.SETF, expansion,
510: args.car());
511: value = eval(form, env, thread);
512: } else {
513: value = eval(args.car(), env, thread);
514: symbol.setSymbolValue(value);
515: }
516: }
517: args = args.cdr();
518: }
519: // Return primary value only!
520: thread.clearValues();
521: return value;
522: }
523: };
524: }
|