source: branches/streams/abcl/src/org/armedbear/lisp/SpecialOperators.java

Last change on this file was 14465, checked in by rschlatte, 13 years ago

new method program_error, analogous to type_error
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 21.1 KB
Line 
1/*
2 * SpecialOperators.java
3 *
4 * Copyright (C) 2003-2007 Peter Graves
5 * $Id: SpecialOperators.java 14465 2013-04-24 12:50:37Z rschlatte $
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., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
20 *
21 * As a special exception, the copyright holders of this library give you
22 * permission to link this library with independent modules to produce an
23 * executable, regardless of the license terms of these independent
24 * modules, and to copy and distribute the resulting executable under
25 * terms of your choice, provided that you also meet, for each linked
26 * independent module, the terms and conditions of the license of that
27 * module.  An independent module is a module which is not derived from
28 * or based on this library.  If you modify this library, you may extend
29 * this exception to your version of the library, but you are not
30 * obligated to do so.  If you do not wish to do so, delete this
31 * exception statement from your version.
32 */
33
34package org.armedbear.lisp;
35
36import static org.armedbear.lisp.Lisp.*;
37
38import java.util.ArrayList;
39import java.util.LinkedList;
40public final class SpecialOperators {
41    // ### quote
42    private static final SpecialOperator QUOTE = new sf_quote();
43    private static final class sf_quote extends SpecialOperator {
44        sf_quote() {
45            super(Symbol.QUOTE, "thing");
46        }
47
48        @Override
49        public LispObject execute(LispObject args, Environment env)
50
51        {
52            if (args.cdr() != NIL)
53                return error(new WrongNumberOfArgumentsException(this, 1));
54            return args.car();
55        }
56    };
57
58    // ### if
59    private static final SpecialOperator IF = new sf_if();
60    private static final class sf_if extends SpecialOperator {
61        sf_if() {
62            super(Symbol.IF, "test then &optional else");
63        }
64
65        @Override
66        public LispObject execute(LispObject args, Environment env)
67
68        {
69            final LispThread thread = LispThread.currentThread();
70            switch (args.length()) {
71            case 2: {
72                if (eval(((Cons)args).car, env, thread) != NIL)
73                    return eval(args.cadr(), env, thread);
74                thread.clearValues();
75                return NIL;
76            }
77            case 3: {
78                if (eval(((Cons)args).car, env, thread) != NIL)
79                    return eval(args.cadr(), env, thread);
80                return eval((((Cons)args).cdr).cadr(), env, thread);
81            }
82            default:
83                return error(new WrongNumberOfArgumentsException(this, 2, 3));
84            }
85        }
86    };
87
88    // ### let
89    private static final SpecialOperator LET = new sf_let();
90    private static final class sf_let extends SpecialOperator {
91        sf_let() {
92            super(Symbol.LET, "bindings &body body");
93        }
94
95        @Override
96        public LispObject execute(LispObject args, Environment env)
97
98        {
99            if (args == NIL)
100                return error(new WrongNumberOfArgumentsException(this, 1, -1));
101            return _let(args, env, false);
102        }
103    };
104
105    // ### let*
106    private static final SpecialOperator LET_STAR = new sf_let_star();
107    private static final class sf_let_star extends SpecialOperator {
108        sf_let_star() {
109            super(Symbol.LET_STAR, "bindings &body body");
110        }
111
112        @Override
113        public LispObject execute(LispObject args, Environment env)
114
115        {
116            if (args == NIL)
117                return error(new WrongNumberOfArgumentsException(this, 1, -1));
118            return _let(args, env, true);
119        }
120    };
121
122    static final LispObject _let(LispObject args, Environment env,
123                                         boolean sequential)
124
125    {
126        final LispThread thread = LispThread.currentThread();
127        final SpecialBindingsMark mark = thread.markSpecialBindings();
128        try {
129            LispObject varList = checkList(args.car());
130            LispObject bodyAndDecls = parseBody(args.cdr(), false);
131            LispObject specials = parseSpecials(bodyAndDecls.NTH(1));
132            LispObject body = bodyAndDecls.car();
133
134            Environment ext = new Environment(env);
135            LinkedList<Cons> nonSequentialVars = new LinkedList<Cons>();
136            while (varList != NIL) {
137                final Symbol symbol;
138                LispObject value;
139                LispObject obj = varList.car();
140                if (obj instanceof Cons) {
141                    if (obj.length() > 2)
142                        return error(new LispError("The " + (sequential ? "LET*" : "LET")
143                                                   + " binding specification " +
144                                                   obj.princToString() + " is invalid."));
145                    symbol = checkSymbol(((Cons)obj).car);
146                    value = eval(obj.cadr(), sequential ? ext : env, thread);
147                } else {
148                    symbol = checkSymbol(obj);
149                    value = NIL;
150                }
151                if (sequential) {
152                    ext = new Environment(ext);
153                    bindArg(specials, symbol, value, ext, thread);
154                } else
155                    nonSequentialVars.add(new Cons(symbol, value));
156                varList = ((Cons)varList).cdr;
157            }
158            if (!sequential)
159for (Cons x : nonSequentialVars)
160                    bindArg(specials, (Symbol)x.car(), x.cdr(), ext, thread);
161
162            // Make sure free special declarations are visible in the body.
163            // "The scope of free declarations specifically does not include
164            // initialization forms for bindings established by the form
165            // containing the declarations." (3.3.4)
166            for (; specials != NIL; specials = specials.cdr())
167                ext.declareSpecial((Symbol)specials.car());
168
169            return progn(body, ext, thread);
170        }
171        finally {
172            thread.resetSpecialBindings(mark);
173        }
174    }
175
176    // ### symbol-macrolet
177    private static final SpecialOperator SYMBOL_MACROLET = new sf_symbol_macrolet();
178    private static final class sf_symbol_macrolet extends SpecialOperator {
179        sf_symbol_macrolet() {
180            super(Symbol.SYMBOL_MACROLET, "macrobindings &body body");
181        }
182
183        @Override
184        public LispObject execute(LispObject args, Environment env)
185
186        {
187            LispObject varList = checkList(args.car());
188            final LispThread thread = LispThread.currentThread();
189            final SpecialBindingsMark mark = thread.markSpecialBindings();
190            Environment ext = new Environment(env);
191            try {
192                // Declare our free specials, this will correctly raise
193                LispObject body = ext.processDeclarations(args.cdr());
194
195                for (int i = varList.length(); i-- > 0;) {
196                    LispObject obj = varList.car();
197                    varList = varList.cdr();
198                    if (obj instanceof Cons && obj.length() == 2) {
199                        Symbol symbol = checkSymbol(obj.car());
200                        if (symbol.isSpecialVariable()
201                                || ext.isDeclaredSpecial(symbol)) {
202                            return program_error("Attempt to bind the special variable "
203                                                 + symbol.princToString()
204                                                 + " with SYMBOL-MACROLET.");
205                        }
206                        ext.bind(symbol, new SymbolMacro(obj.cadr()));
207                    } else {
208                        return program_error("Malformed symbol-expansion pair in SYMBOL-MACROLET: "
209                                             + obj.princToString() + ".");
210                    }
211                }
212                return progn(body, ext, thread);
213            }
214            finally {
215                thread.resetSpecialBindings(mark);
216            }
217        }
218    };
219
220    // ### load-time-value form &optional read-only-p => object
221    private static final SpecialOperator LOAD_TIME_VALUE = new sf_load_time_value();
222    private static final class sf_load_time_value extends SpecialOperator {
223        sf_load_time_value() {
224            super(Symbol.LOAD_TIME_VALUE,
225                  "form &optional read-only-p");
226        }
227
228        @Override
229        public LispObject execute(LispObject args, Environment env)
230
231        {
232            switch (args.length()) {
233            case 1:
234            case 2:
235                return eval(args.car(), new Environment(),
236                            LispThread.currentThread());
237            default:
238                return error(new WrongNumberOfArgumentsException(this, 1, 2));
239            }
240        }
241    };
242
243    // ### locally
244    private static final SpecialOperator LOCALLY = new sf_locally();
245    private static final class sf_locally extends SpecialOperator {
246        sf_locally() {
247            super(Symbol.LOCALLY, "&body body");
248        }
249
250        @Override
251        public LispObject execute(LispObject args, Environment env)
252
253        {
254            final LispThread thread = LispThread.currentThread();
255            final Environment ext = new Environment(env);
256            args = ext.processDeclarations(args);
257            return progn(args, ext, thread);
258        }
259    };
260
261    // ### progn
262    private static final SpecialOperator PROGN = new sf_progn();
263    private static final class sf_progn extends SpecialOperator {
264        sf_progn() {
265            super(Symbol.PROGN, "&rest forms");
266        }
267
268        @Override
269        public LispObject execute(LispObject args, Environment env)
270
271        {
272            LispThread thread = LispThread.currentThread();
273            return progn(args, env, thread);
274        }
275    };
276
277    // ### flet
278    private static final SpecialOperator FLET = new sf_flet();
279    private static final class sf_flet extends SpecialOperator {
280        sf_flet() {
281            super(Symbol.FLET, "definitions &body body");
282        }
283
284        @Override
285        public LispObject execute(LispObject args, Environment env)
286
287        {
288            return _flet(args, env, false);
289        }
290    };
291
292    // ### labels
293    private static final SpecialOperator LABELS = new sf_labels();
294    private static final class sf_labels extends SpecialOperator {
295        sf_labels() {
296            super(Symbol.LABELS, "definitions &body body");
297        }
298
299        @Override
300        public LispObject execute(LispObject args, Environment env)
301
302        {
303            return _flet(args, env, true);
304        }
305    };
306
307    static final LispObject _flet(LispObject args, Environment env,
308                                          boolean recursive)
309
310    {
311        // First argument is a list of local function definitions.
312        LispObject defs = checkList(args.car());
313        final LispThread thread = LispThread.currentThread();
314        final SpecialBindingsMark mark = thread.markSpecialBindings();
315        final Environment funEnv = new Environment(env);
316        while (defs != NIL) {
317            final LispObject def = checkList(defs.car());
318            final LispObject name = def.car();
319            final Symbol symbol;
320            if (name instanceof Symbol) {
321                symbol = checkSymbol(name);
322                if (symbol.getSymbolFunction() instanceof SpecialOperator) {
323                  return program_error(symbol.getName()
324                                       + " is a special operator and may not be redefined.");
325                }
326            } else if (isValidSetfFunctionName(name))
327                symbol = checkSymbol(name.cadr());
328            else
329                return type_error(name, FUNCTION_NAME);
330            LispObject rest = def.cdr();
331            LispObject parameters = rest.car();
332            LispObject body = rest.cdr();
333            LispObject decls = NIL;
334            while (body.car() instanceof Cons && body.car().car() == Symbol.DECLARE) {
335                decls = new Cons(body.car(), decls);
336                body = body.cdr();
337            }
338            body = new Cons(symbol, body);
339            body = new Cons(Symbol.BLOCK, body);
340            body = new Cons(body, NIL);
341            while (decls != NIL) {
342                body = new Cons(decls.car(), body);
343                decls = decls.cdr();
344            }
345            LispObject lambda_expression =
346                new Cons(Symbol.LAMBDA, new Cons(parameters, body));
347            LispObject lambda_name =
348                list(recursive ? Symbol.LABELS : Symbol.FLET, name);
349            Closure closure =
350                new Closure(lambda_name, lambda_expression,
351                            recursive ? funEnv : env);
352            funEnv.addFunctionBinding(name, closure);
353            defs = defs.cdr();
354        }
355        try {
356            final Environment ext = new Environment(funEnv);
357            LispObject body = args.cdr();
358            body = ext.processDeclarations(body);
359            return progn(body, ext, thread);
360        }
361        finally {
362            thread.resetSpecialBindings(mark);
363        }
364    }
365
366    // ### the value-type form => result*
367    private static final SpecialOperator THE = new sf_the();
368    private static final class sf_the extends SpecialOperator {
369        sf_the() {
370            super(Symbol.THE, "type value");
371        }
372
373        @Override
374        public LispObject execute(LispObject args, Environment env)
375
376        {
377            if (args.length() != 2)
378                return error(new WrongNumberOfArgumentsException(this, 2));
379            LispObject rv = eval(args.cadr(), env, LispThread.currentThread());
380
381            // check only the most simple types: single symbols
382            // (class type specifiers/primitive types)
383            // DEFTYPE-d types need expansion;
384            // doing so would slow down our execution too much
385
386            // An implementation is allowed not to check the type,
387            // the fact that we do so here is mainly driven by the
388            // requirement to verify argument types in structure-slot
389            // accessors (defstruct.lisp)
390
391            // The policy below is in line with the level of verification
392            // in the compiler at *safety* levels below 3
393            LispObject type = args.car();
394            if ((type instanceof Symbol
395                    && get(type, Symbol.DEFTYPE_DEFINITION) == NIL)
396                    || type instanceof BuiltInClass)
397                if (rv.typep(type) == NIL)
398                    type_error(rv, type);
399
400            return rv;
401        }
402    };
403
404    // ### progv
405    private static final SpecialOperator PROGV = new sf_progv();
406    private static final class sf_progv extends SpecialOperator {
407        sf_progv() {
408            super(Symbol.PROGV, "symbols values &body body");
409        }
410
411        @Override
412        public LispObject execute(LispObject args, Environment env)
413
414        {
415            if (args.length() < 2)
416                return error(new WrongNumberOfArgumentsException(this, 2, -1));
417            final LispThread thread = LispThread.currentThread();
418            final LispObject symbols = checkList(eval(args.car(), env, thread));
419            LispObject values = checkList(eval(args.cadr(), env, thread));
420            final SpecialBindingsMark mark = thread.markSpecialBindings();
421            try {
422                // Set up the new bindings.
423                progvBindVars(symbols, values, thread);
424                // Implicit PROGN.
425                return progn(args.cdr().cdr(), env, thread);
426            }
427            finally {
428                thread.resetSpecialBindings(mark);
429            }
430        }
431    };
432
433    // ### declare
434    private static final SpecialOperator DECLARE = new sf_declare();
435    private static final class sf_declare extends SpecialOperator {
436        sf_declare() {
437            super(Symbol.DECLARE, "&rest declaration-specifiers");
438        }
439
440        @Override
441        public LispObject execute(LispObject args, Environment env)
442
443        {
444            return NIL;
445        }
446    };
447
448    // ### function
449    private static final SpecialOperator FUNCTION = new sf_function();
450    private static final class sf_function extends SpecialOperator {
451        sf_function() {
452            super(Symbol.FUNCTION, "thing");
453        }
454
455        @Override
456        public LispObject execute(LispObject args, Environment env)
457
458        {
459            final LispObject arg = args.car();
460            if (arg instanceof Symbol) {
461                LispObject operator = env.lookupFunction(arg);
462                if (operator instanceof Autoload) {
463                    Autoload autoload = (Autoload) operator;
464                    autoload.load();
465                    operator = autoload.getSymbol().getSymbolFunction();
466                }
467                if (operator instanceof Function)
468                    return operator;
469                if (operator instanceof FuncallableStandardObject)
470                    return operator;
471                return error(new UndefinedFunction(arg));
472            }
473            if (arg instanceof Cons) {
474                LispObject car = ((Cons)arg).car;
475                if (car == Symbol.SETF) {
476                    LispObject f = env.lookupFunction(arg);
477                    if (f != null)
478                        return f;
479                    Symbol symbol = checkSymbol(arg.cadr());
480                    f = get(symbol, Symbol.SETF_FUNCTION, null);
481                    if (f != null)
482                        return f;
483                    f = get(symbol, Symbol.SETF_INVERSE, null);
484                    if (f != null)
485                        return f;
486                }
487                if (car == Symbol.LAMBDA)
488                    return new Closure(arg, env);
489                if (car == Symbol.NAMED_LAMBDA) {
490                    LispObject name = arg.cadr();
491                    if (name instanceof Symbol || isValidSetfFunctionName(name)) {
492                        return new Closure(name,
493                                           new Cons(Symbol.LAMBDA, arg.cddr()),
494                                           env);
495                    }
496                    return type_error(name, FUNCTION_NAME);
497                }
498                if (car == Symbol.MACRO_FUNCTION)
499                    return new Closure(arg, env);
500            }
501            return error(new UndefinedFunction(list(Keyword.NAME, arg)));
502        }
503    };
504
505    // ### setq
506    private static final SpecialOperator SETQ = new sf_setq();
507    private static final class sf_setq extends SpecialOperator {
508        sf_setq() {
509            super(Symbol.SETQ, "&rest vars-and-values");
510        }
511
512        @Override
513        public LispObject execute(LispObject args, Environment env)
514
515        {
516            LispObject value = Nil.NIL;
517            final LispThread thread = LispThread.currentThread();
518            while (args != NIL) {
519                Symbol symbol = checkSymbol(args.car());
520                if (symbol.isConstant()) {
521                    return program_error(symbol.princToString()
522                                         + " is a constant and thus cannot be set.");
523                }
524                args = args.cdr();
525                if (symbol.isSpecialVariable() || env.isDeclaredSpecial(symbol)) {
526                    SpecialBinding binding = thread.getSpecialBinding(symbol);
527                    value = eval(args.car(), env, thread);
528                    if (binding != null) {
529                        binding.value = value;
530                    } else {
531                        symbol.setSymbolValue(value);
532                    }
533                } else {
534                    // Not special.
535                    Binding binding = env.getBinding(symbol);
536                    if (binding != null) {
537                        if (binding.value instanceof SymbolMacro) {
538                            LispObject expansion =
539                                ((SymbolMacro)binding.value).getExpansion();
540                            LispObject form = list(Symbol.SETF, expansion, args.car());
541                            value = eval(form, env, thread);
542                        } else {
543                            value = eval(args.car(), env, thread);
544                            binding.value = value;
545                        }
546                    } else {
547                        if (symbol.getSymbolMacro() != null) {
548                            LispObject expansion =
549                                symbol.getSymbolMacro().getExpansion();
550                            LispObject form = list(Symbol.SETF, expansion, args.car());
551                            value = eval(form, env, thread);
552                        } else {
553                            value = eval(args.car(), env, thread);
554                            symbol.setSymbolValue(value);
555                        }
556                    }
557                }
558                args = args.cdr();
559            }
560            // Return primary value only!
561            thread._values = null;
562            return value;
563        }
564    };
565}
Note: See TracBrowser for help on using the repository browser.