KickJava   Java API By Example, From Geeks To Geeks.

Java > Open Source Codes > org > armedbear > lisp > SpecialOperators


1 /*
2  * SpecialOperators.java
3  *
4  * Copyright (C) 2003-2004 Peter Graves
5  * $Id: SpecialOperators.java,v 1.30 2004/09/19 17:12:01 asimon Exp $
6  *
7  * This program is free software; you can redistribute it and/or
8  * modify it under the terms of the GNU General Public License
9  * as published by the Free Software Foundation; either version 2
10  * of the License, or (at your option) any later version.
11  *
12  * This program is distributed in the hope that it will be useful,
13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15  * GNU General Public License for more details.
16  *
17  * You should have received a copy of the GNU General Public License
18  * along with this program; if not, write to the Free Software
19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
20  */

21
22 package org.armedbear.lisp;
23
24 import java.util.ArrayList JavaDoc;
25
26 public final class SpecialOperators extends Lisp
27 {
28     // ### quote
29
private static final SpecialOperator QUOTE = new SpecialOperator("quote", "thing") {
30         public LispObject execute(LispObject args, Environment env)
31             throws ConditionThrowable
32         {
33             return args.car();
34         }
35     };
36
37     // ### if
38
private static final SpecialOperator IF = new SpecialOperator("if", "test then &optional else") {
39         public LispObject execute(LispObject args, Environment env)
40             throws ConditionThrowable
41         {
42             final LispThread thread = LispThread.currentThread();
43             switch (args.length()) {
44                 case 2: {
45                     if (eval(args.car(), env, thread) != NIL)
46                         return eval(args.cadr(), env, thread);
47                     return NIL;
48                 }
49                 case 3: {
50                     if (eval(args.car(), env, thread) != NIL)
51                         return eval(args.cadr(), env, thread);
52                     return eval(args.cdr().cadr(), env, thread);
53                 }
54                 default:
55                     return signal(new WrongNumberOfArgumentsException("IF"));
56             }
57         }
58     };
59
60     // ### let
61
private static final SpecialOperator LET = new SpecialOperator("let", "bindings &body body")
62     {
63         public LispObject execute(LispObject args, Environment env)
64             throws ConditionThrowable
65         {
66             return _let(args, env, false);
67         }
68     };
69
70     // ### let*
71
private static final SpecialOperator LETX = new SpecialOperator("let*", "bindings &body body")
72     {
73         public LispObject execute(LispObject args, Environment env)
74             throws ConditionThrowable
75         {
76             return _let(args, env, true);
77         }
78     };
79
80     private static final LispObject _let(LispObject args, Environment env,
81                                          boolean sequential)
82         throws ConditionThrowable
83     {
84         LispObject result = NIL;
85         final LispThread thread = LispThread.currentThread();
86         final Environment oldDynEnv = thread.getDynamicEnvironment();
87         try {
88             LispObject varList = checkList(args.car());
89             LispObject body = args.cdr();
90             // Process declarations.
91
LispObject specials = NIL;
92             while (body != NIL) {
93                 LispObject obj = body.car();
94                 if (obj instanceof Cons && obj.car() == Symbol.DECLARE) {
95                     LispObject decls = obj.cdr();
96                     while (decls != NIL) {
97                         LispObject decl = decls.car();
98                         if (decl instanceof Cons && decl.car() == Symbol.SPECIAL) {
99                             LispObject vars = decl.cdr();
100                             while (vars != NIL) {
101                                 specials = new Cons(vars.car(), specials);
102                                 vars = vars.cdr();
103                             }
104                         }
105                         decls = decls.cdr();
106                     }
107                     body = body.cdr();
108                 } else
109                     break;
110             }
111             Environment ext = new Environment(env);
112             if (sequential) {
113                 // LET*
114
while (varList != NIL) {
115                     Symbol symbol;
116                     LispObject value;
117                     LispObject obj = varList.car();
118                     if (obj instanceof Cons) {
119                         symbol = checkSymbol(obj.car());
120                         value = eval(obj.cadr(), ext, thread);
121                     } else {
122                         symbol = checkSymbol(obj);
123                         value = NIL;
124                     }
125                     if (specials != NIL && memq(symbol, specials)) {
126                         thread.bindSpecial(symbol, value);
127                         ext.declareSpecial(symbol);
128                     } else if (symbol.isSpecialVariable()) {
129                         thread.bindSpecial(symbol, value);
130                     } else
131                         ext.bind(symbol, value);
132                     varList = varList.cdr();
133                 }
134             } else {
135                 // LET
136
final int length = varList.length();
137                 LispObject[] vals = new LispObject[length];
138                 for (int i = 0; i < length; i++) {
139                     LispObject obj = varList.car();
140                     if (obj instanceof Cons)
141                         vals[i] = eval(obj.cadr(), env, thread);
142                     else
143                         vals[i] = NIL;
144                     varList = varList.cdr();
145                 }
146                 varList = args.car();
147                 int i = 0;
148                 while (varList != NIL) {
149                     Symbol symbol;
150                     LispObject obj = varList.car();
151                     if (obj instanceof Cons)
152                         symbol = checkSymbol(obj.car());
153                     else
154                         symbol = checkSymbol(obj);
155                     LispObject value = vals[i];
156                     if (specials != NIL && memq(symbol, specials)) {
157                         thread.bindSpecial(symbol, value);
158                         ext.declareSpecial(symbol);
159                     } else if (symbol.isSpecialVariable()) {
160                         thread.bindSpecial(symbol, value);
161                     } else
162                         ext.bind(symbol, value);
163                     varList = varList.cdr();
164                     ++i;
165                 }
166             }
167             while (body != NIL) {
168                 result = eval(body.car(), ext, thread);
169                 body = body.cdr();
170             }
171         }
172         finally {
173             thread.setDynamicEnvironment(oldDynEnv);
174         }
175         return result;
176     }
177
178     // ### symbol-macrolet
179
private static final SpecialOperator SYMBOL_MACROLET =
180         new SpecialOperator("symbol-macrolet", "macrobindings &body body")
181     {
182         public LispObject execute(LispObject args, Environment env)
183             throws ConditionThrowable
184         {
185             boolean sequential = true; // FIXME Is this right?
186
LispObject varList = checkList(args.car());
187             final LispThread thread = LispThread.currentThread();
188             LispObject result = NIL;
189             if (varList != NIL) {
190                 Environment oldDynEnv = thread.getDynamicEnvironment();
191                 try {
192                     Environment ext = new Environment(env);
193                     Environment evalEnv = sequential ? ext : env;
194                     for (int i = varList.length(); i-- > 0;) {
195                         LispObject obj = varList.car();
196                         varList = varList.cdr();
197                         if (obj instanceof Cons && obj.length() == 2) {
198                             Symbol symbol = checkSymbol(obj.car());
199                             if (symbol.isSpecialVariable()) {
200                                 return signal(new ProgramError(
201                                     "Attempt to bind the special variable " +
202                                     symbol.writeToString() +
203                                     " with SYMBOL-MACROLET."));
204                             }
205                             bind(symbol, new SymbolMacro(obj.cadr()), ext);
206                         } else {
207                             return signal(new ProgramError(
208                                 "Malformed symbol-expansion pair in SYMBOL-MACROLET: " +
209                                 obj.writeToString()));
210                         }
211                     }
212                     LispObject body = args.cdr();
213                     while (body != NIL) {
214                         result = eval(body.car(), ext, thread);
215                         body = body.cdr();
216                     }
217                 }
218                 finally {
219                     thread.setDynamicEnvironment(oldDynEnv);
220                 }
221             } else {
222                 LispObject body = args.cdr();
223                 while (body != NIL) {
224                     result = eval(body.car(), env, thread);
225                     body = body.cdr();
226                 }
227             }
228             return result;
229         }
230     };
231
232     // ### load-time-value
233
// load-time-value form &optional read-only-p => object
234
private static final SpecialOperator LOAD_TIME_VALUE =
235         new SpecialOperator("load-time-value", "form &optional read-only-p")
236     {
237         public LispObject execute(LispObject args, Environment env)
238             throws ConditionThrowable
239         {
240             switch (args.length()) {
241                 case 1:
242                 case 2:
243                     return eval(args.car(), new Environment(),
244                                 LispThread.currentThread());
245                 default:
246                     return signal(new WrongNumberOfArgumentsException(this));
247             }
248         }
249     };
250
251     // ### locally
252
private static final SpecialOperator LOCALLY = new SpecialOperator("locally", "&body body")
253     {
254         public LispObject execute(LispObject args, Environment env)
255             throws ConditionThrowable
256         {
257             final LispThread thread = LispThread.currentThread();
258             final Environment ext = new Environment(env);
259             args = ext.processDeclarations(args);
260             LispObject result = NIL;
261             while (args != NIL) {
262                 result = eval(args.car(), ext, thread);
263                 args = args.cdr();
264             }
265             return result;
266         }
267     };
268
269     // ### progn
270
private static final SpecialOperator PROGN = new SpecialOperator("progn", "&rest forms")
271     {
272         public LispObject execute(LispObject args, Environment env)
273             throws ConditionThrowable
274         {
275             LispThread thread = LispThread.currentThread();
276             LispObject result = NIL;
277             while (args != NIL) {
278                 result = eval(args.car(), env, thread);
279                 args = args.cdr();
280             }
281             return result;
282         }
283     };
284
285     private static final SpecialOperator FLET = new SpecialOperator("flet", "definitions &body body")
286     {
287         public LispObject execute(LispObject args, Environment env)
288             throws ConditionThrowable
289         {
290             return _flet(args, env, false);
291         }
292     };
293
294     private static final SpecialOperator LABELS = new SpecialOperator("labels", "definitions &body body")
295     {
296         public LispObject execute(LispObject args, Environment env)
297             throws ConditionThrowable
298         {
299             return _flet(args, env, true);
300         }
301     };
302
303     private static final LispObject _flet(LispObject args, Environment env,
304                                           boolean recursive)
305         throws ConditionThrowable
306     {
307         // First argument is a list of local function definitions.
308
LispObject defs = checkList(args.car());
309         final LispThread thread = LispThread.currentThread();
310         LispObject result;
311         if (defs != NIL) {
312             Environment oldDynEnv = thread.getDynamicEnvironment();
313             Environment ext = new Environment(env);
314             while (defs != NIL) {
315                 final LispObject def = checkList(defs.car());
316                 final LispObject name = def.car();
317                 final Symbol symbol;
318                 if (name instanceof Symbol) {
319                     symbol = checkSymbol(name);
320                     if (symbol.getSymbolFunction() instanceof SpecialOperator) {
321                         String JavaDoc message =
322                             symbol.getName() + " is a special operator and may not be redefined";
323                         return signal(new ProgramError(message));
324                     }
325                 } else if (name instanceof Cons && name.car() == Symbol.SETF) {
326                     symbol = checkSymbol(name.cadr());
327                 } else
328                     return signal(new TypeError(name, "valid function name"));
329                 LispObject rest = def.cdr();
330                 LispObject parameters = rest.car();
331                 LispObject body = rest.cdr();
332                 LispObject decls = NIL;
333                 while (body.car() instanceof Cons && body.car().car() == Symbol.DECLARE) {
334                     decls = new Cons(body.car(), decls);
335                     body = body.cdr();
336                 }
337                 body = new Cons(symbol, body);
338                 body = new Cons(Symbol.BLOCK, body);
339                 body = new Cons(body, NIL);
340                 while (decls != NIL) {
341                     body = new Cons(decls.car(), body);
342                     decls = decls.cdr();
343                 }
344                 Closure closure;
345                 if (recursive)
346                     closure = new Closure(parameters, body, ext);
347                 else
348                     closure = new Closure(parameters, body, env);
349                 closure.setLambdaName(list2(Symbol.FLET, name));
350                 ext.bindFunctional(name, closure);
351                 defs = defs.cdr();
352             }
353             try {
354                 result = progn(args.cdr(), ext, thread);
355             }
356             finally {
357                 thread.setDynamicEnvironment(oldDynEnv);
358             }
359         } else
360             result = progn(args.cdr(), env, thread);
361         return result;
362     }
363
364     // ### the
365
// the value-type form => result*
366
private static final SpecialOperator THE = new SpecialOperator("the", "type value") {
367         public LispObject execute(LispObject args, Environment env)
368             throws ConditionThrowable
369         {
370             if (args.length() != 2)
371                 return signal(new WrongNumberOfArgumentsException(this));
372             return eval(args.cadr(), env, LispThread.currentThread());
373         }
374     };
375
376     // ### progv
377
private static final SpecialOperator PROGV = new SpecialOperator("progv", "vars vals &body body")
378     {
379         public LispObject execute(LispObject args, Environment env)
380             throws ConditionThrowable
381         {
382             if (args.length() < 2)
383                 return signal(new WrongNumberOfArgumentsException(this));
384             final LispThread thread = LispThread.currentThread();
385             final LispObject symbols = checkList(eval(args.car(), env, thread));
386             LispObject values = checkList(eval(args.cadr(), env, thread));
387             Environment oldDynEnv = thread.getDynamicEnvironment();
388             try {
389                 // Set up the new bindings.
390
for (LispObject list = symbols; list != NIL; list = list.cdr()) {
391                     Symbol symbol = checkSymbol(list.car());
392                     LispObject value;
393                     if (values != NIL) {
394                         value = values.car();
395                         values = values.cdr();
396                     } else
397                         value = null;
398                     thread.bindSpecial(symbol, value);
399                 }
400                 // Implicit PROGN.
401
LispObject result = NIL;
402                 LispObject body = args.cdr().cdr();
403                 while (body != NIL) {
404                     result = eval(body.car(), env, thread);
405                     body = body.cdr();
406                 }
407                 return result;
408             }
409             finally {
410                 thread.setDynamicEnvironment(oldDynEnv);
411             }
412         }
413     };
414
415     // ### declare
416
private static final SpecialOperator DECLARE = new SpecialOperator("declare", "&rest declaration-specifiers")
417     {
418         public LispObject execute(LispObject args, Environment env)
419             throws ConditionThrowable
420         {
421             while (args != NIL) {
422                 LispObject decl = args.car();
423                 args = args.cdr();
424                 if (decl instanceof Cons && decl.car() == Symbol.SPECIAL) {
425                     LispObject vars = decl.cdr();
426                     while (vars != NIL) {
427                         Symbol var = checkSymbol(vars.car());
428                         env.declareSpecial(var);
429                         vars = vars.cdr();
430                     }
431                 }
432             }
433             return NIL;
434         }
435     };
436
437     // ### function
438
private static final SpecialOperator FUNCTION = new SpecialOperator("function", "thing")
439     {
440         public LispObject execute(LispObject args, Environment env)
441             throws ConditionThrowable
442         {
443             final LispObject arg = args.car();
444             if (arg instanceof Symbol) {
445                 LispObject functional = env.lookupFunctional(arg);
446                 if (functional instanceof Autoload) {
447                     Autoload autoload = (Autoload) functional;
448                     autoload.load();
449                     functional = autoload.getSymbol().getSymbolFunction();
450                 }
451                 if (functional instanceof Function)
452                     return functional;
453                 if (functional instanceof GenericFunction)
454                     return functional;
455                 return signal(new UndefinedFunction(arg));
456             }
457             if (arg instanceof Cons) {
458                 if (arg.car() == Symbol.LAMBDA)
459                     return new Closure(arg.cadr(), arg.cddr(), env);
460                 if (arg.car() == Symbol.SETF) {
461                     LispObject f = env.lookupFunctional(arg);
462                     if (f != null)
463                         return f;
464                     Symbol symbol = checkSymbol(arg.cadr());
465                     f = get(symbol, Symbol._SETF_FUNCTION);
466                     if (f != null)
467                         return f;
468                     f = get(symbol, PACKAGE_SYS.intern("SETF-INVERSE"));
469                     if (f != null)
470                         return f;
471                 }
472             }
473             return signal(new UndefinedFunction(list2(Keyword.NAME, arg)));
474         }
475     };
476
477     // ### setq
478
private static final SpecialOperator SETQ = new SpecialOperator("setq", "&rest vars-and-values")
479     {
480         public LispObject execute(LispObject args, Environment env)
481             throws ConditionThrowable
482         {
483             LispObject value = Symbol.NIL;
484             final LispThread thread = LispThread.currentThread();
485             while (args != NIL) {
486                 Symbol symbol = checkSymbol(args.car());
487                 if (symbol.isConstant()) {
488                     return signal(new ProgramError(symbol.writeToString() +
489                         " is a constant and thus cannot be set."));
490                 }
491                 args = args.cdr();
492                 Binding binding = null;
493                 if (env.isDeclaredSpecial(symbol) || symbol.isSpecialVariable()) {
494                     Environment dynEnv = thread.getDynamicEnvironment();
495                     if (dynEnv != null)
496                         binding = dynEnv.getBinding(symbol);
497                 } else {
498                     // Not special.
499
binding = env.getBinding(symbol);
500                 }
501                 if (binding != null) {
502                     if (binding.value instanceof SymbolMacro) {
503                         LispObject expansion =
504                             ((SymbolMacro)binding.value).getExpansion();
505                         LispObject form = list3(Symbol.SETF, expansion, args.car());
506                         value = eval(form, env, thread);
507                     } else {
508                         value = eval(args.car(), env, thread);
509                         binding.value = value;
510                     }
511                 } else {
512                     if (symbol.getSymbolValue() instanceof SymbolMacro) {
513                         LispObject expansion =
514                             ((SymbolMacro)symbol.getSymbolValue()).getExpansion();
515                         LispObject form = list3(Symbol.SETF, expansion, args.car());
516                         value = eval(form, env, thread);
517                     } else {
518                         value = eval(args.car(), env, thread);
519                         symbol.setSymbolValue(value);
520                     }
521                 }
522                 args = args.cdr();
523             }
524             // Return primary value only!
525
thread.clearValues();
526             return value;
527         }
528     };
529 }
530
Popular Tags