source: branches/1.1.x/src/org/armedbear/lisp/SpecialOperators.java

Last change on this file was 14131, checked in by ehuelsmann, 12 years ago

Close #219: lambda list keyword checking too lenient for ANSI.

Note: This introduces a new argument to the FUNCTION special form

(LAMBDA and NAMED-LAMBDA were already supported)
(FUNCTION (MACRO-FUNCTION ...))
  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 21.3 KB
Line 
1/*
2 * SpecialOperators.java
3 *
4 * Copyright (C) 2003-2007 Peter Graves
5 * $Id: SpecialOperators.java 14131 2012-08-21 14:00:13Z ehuelsmann $
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 error(new ProgramError(
203                                             "Attempt to bind the special variable " +
204                                             symbol.princToString() +
205                                             " with SYMBOL-MACROLET."));
206                        }
207                        ext.bind(symbol, new SymbolMacro(obj.cadr()));
208                    } else {
209                        return error(new ProgramError(
210                                         "Malformed symbol-expansion pair in SYMBOL-MACROLET: " +
211                                         obj.princToString()));
212                    }
213                }
214                return progn(body, ext, thread);
215            }
216            finally {
217                thread.resetSpecialBindings(mark);
218            }
219        }
220    };
221
222    // ### load-time-value form &optional read-only-p => object
223    private static final SpecialOperator LOAD_TIME_VALUE = new sf_load_time_value();
224    private static final class sf_load_time_value extends SpecialOperator {
225        sf_load_time_value() {
226            super(Symbol.LOAD_TIME_VALUE,
227                  "form &optional read-only-p");
228        }
229
230        @Override
231        public LispObject execute(LispObject args, Environment env)
232
233        {
234            switch (args.length()) {
235            case 1:
236            case 2:
237                return eval(args.car(), new Environment(),
238                            LispThread.currentThread());
239            default:
240                return error(new WrongNumberOfArgumentsException(this, 1, 2));
241            }
242        }
243    };
244
245    // ### locally
246    private static final SpecialOperator LOCALLY = new sf_locally();
247    private static final class sf_locally extends SpecialOperator {
248        sf_locally() {
249            super(Symbol.LOCALLY, "&body body");
250        }
251
252        @Override
253        public LispObject execute(LispObject args, Environment env)
254
255        {
256            final LispThread thread = LispThread.currentThread();
257            final Environment ext = new Environment(env);
258            args = ext.processDeclarations(args);
259            return progn(args, ext, thread);
260        }
261    };
262
263    // ### progn
264    private static final SpecialOperator PROGN = new sf_progn();
265    private static final class sf_progn extends SpecialOperator {
266        sf_progn() {
267            super(Symbol.PROGN, "&rest forms");
268        }
269
270        @Override
271        public LispObject execute(LispObject args, Environment env)
272
273        {
274            LispThread thread = LispThread.currentThread();
275            return progn(args, env, thread);
276        }
277    };
278
279    // ### flet
280    private static final SpecialOperator FLET = new sf_flet();
281    private static final class sf_flet extends SpecialOperator {
282        sf_flet() {
283            super(Symbol.FLET, "definitions &body body");
284        }
285
286        @Override
287        public LispObject execute(LispObject args, Environment env)
288
289        {
290            return _flet(args, env, false);
291        }
292    };
293
294    // ### labels
295    private static final SpecialOperator LABELS = new sf_labels();
296    private static final class sf_labels extends SpecialOperator {
297        sf_labels() {
298            super(Symbol.LABELS, "definitions &body body");
299        }
300
301        @Override
302        public LispObject execute(LispObject args, Environment env)
303
304        {
305            return _flet(args, env, true);
306        }
307    };
308
309    static final LispObject _flet(LispObject args, Environment env,
310                                          boolean recursive)
311
312    {
313        // First argument is a list of local function definitions.
314        LispObject defs = checkList(args.car());
315        final LispThread thread = LispThread.currentThread();
316        final SpecialBindingsMark mark = thread.markSpecialBindings();
317        final Environment funEnv = new Environment(env);
318        while (defs != NIL) {
319            final LispObject def = checkList(defs.car());
320            final LispObject name = def.car();
321            final Symbol symbol;
322            if (name instanceof Symbol) {
323                symbol = checkSymbol(name);
324                if (symbol.getSymbolFunction() instanceof SpecialOperator) {
325                    String message =
326                        symbol.getName() + " is a special operator and may not be redefined";
327                    return error(new ProgramError(message));
328                }
329            } else if (isValidSetfFunctionName(name))
330                symbol = checkSymbol(name.cadr());
331            else
332                return type_error(name, FUNCTION_NAME);
333            LispObject rest = def.cdr();
334            LispObject parameters = rest.car();
335            LispObject body = rest.cdr();
336            LispObject decls = NIL;
337            while (body.car() instanceof Cons && body.car().car() == Symbol.DECLARE) {
338                decls = new Cons(body.car(), decls);
339                body = body.cdr();
340            }
341            body = new Cons(symbol, body);
342            body = new Cons(Symbol.BLOCK, body);
343            body = new Cons(body, NIL);
344            while (decls != NIL) {
345                body = new Cons(decls.car(), body);
346                decls = decls.cdr();
347            }
348            LispObject lambda_expression =
349                new Cons(Symbol.LAMBDA, new Cons(parameters, body));
350            LispObject lambda_name =
351                list(recursive ? Symbol.LABELS : Symbol.FLET, name);
352            Closure closure =
353                new Closure(lambda_name, lambda_expression,
354                            recursive ? funEnv : env);
355            funEnv.addFunctionBinding(name, closure);
356            defs = defs.cdr();
357        }
358        try {
359            final Environment ext = new Environment(funEnv);
360            LispObject body = args.cdr();
361            body = ext.processDeclarations(body);
362            return progn(body, ext, thread);
363        }
364        finally {
365            thread.resetSpecialBindings(mark);
366        }
367    }
368
369    // ### the value-type form => result*
370    private static final SpecialOperator THE = new sf_the();
371    private static final class sf_the extends SpecialOperator {
372        sf_the() {
373            super(Symbol.THE, "type value");
374        }
375
376        @Override
377        public LispObject execute(LispObject args, Environment env)
378
379        {
380            if (args.length() != 2)
381                return error(new WrongNumberOfArgumentsException(this, 2));
382            LispObject rv = eval(args.cadr(), env, LispThread.currentThread());
383
384            // check only the most simple types: single symbols
385            // (class type specifiers/primitive types)
386            // DEFTYPE-d types need expansion;
387            // doing so would slow down our execution too much
388
389            // An implementation is allowed not to check the type,
390            // the fact that we do so here is mainly driven by the
391            // requirement to verify argument types in structure-slot
392            // accessors (defstruct.lisp)
393
394            // The policy below is in line with the level of verification
395            // in the compiler at *safety* levels below 3
396            LispObject type = args.car();
397            if ((type instanceof Symbol
398                    && get(type, Symbol.DEFTYPE_DEFINITION) == NIL)
399                    || type instanceof BuiltInClass)
400                if (rv.typep(type) == NIL)
401                    type_error(rv, type);
402
403            return rv;
404        }
405    };
406
407    // ### progv
408    private static final SpecialOperator PROGV = new sf_progv();
409    private static final class sf_progv extends SpecialOperator {
410        sf_progv() {
411            super(Symbol.PROGV, "symbols values &body body");
412        }
413
414        @Override
415        public LispObject execute(LispObject args, Environment env)
416
417        {
418            if (args.length() < 2)
419                return error(new WrongNumberOfArgumentsException(this, 2, -1));
420            final LispThread thread = LispThread.currentThread();
421            final LispObject symbols = checkList(eval(args.car(), env, thread));
422            LispObject values = checkList(eval(args.cadr(), env, thread));
423            final SpecialBindingsMark mark = thread.markSpecialBindings();
424            try {
425                // Set up the new bindings.
426                progvBindVars(symbols, values, thread);
427                // Implicit PROGN.
428                return progn(args.cdr().cdr(), env, thread);
429            }
430            finally {
431                thread.resetSpecialBindings(mark);
432            }
433        }
434    };
435
436    // ### declare
437    private static final SpecialOperator DECLARE = new sf_declare();
438    private static final class sf_declare extends SpecialOperator {
439        sf_declare() {
440            super(Symbol.DECLARE, "&rest declaration-specifiers");
441        }
442
443        @Override
444        public LispObject execute(LispObject args, Environment env)
445
446        {
447            return NIL;
448        }
449    };
450
451    // ### function
452    private static final SpecialOperator FUNCTION = new sf_function();
453    private static final class sf_function extends SpecialOperator {
454        sf_function() {
455            super(Symbol.FUNCTION, "thing");
456        }
457
458        @Override
459        public LispObject execute(LispObject args, Environment env)
460
461        {
462            final LispObject arg = args.car();
463            if (arg instanceof Symbol) {
464                LispObject operator = env.lookupFunction(arg);
465                if (operator instanceof Autoload) {
466                    Autoload autoload = (Autoload) operator;
467                    autoload.load();
468                    operator = autoload.getSymbol().getSymbolFunction();
469                }
470                if (operator instanceof Function)
471                    return operator;
472                if (operator instanceof StandardGenericFunction)
473                    return operator;
474                return error(new UndefinedFunction(arg));
475            }
476            if (arg instanceof Cons) {
477                LispObject car = ((Cons)arg).car;
478                if (car == Symbol.SETF) {
479                    LispObject f = env.lookupFunction(arg);
480                    if (f != null)
481                        return f;
482                    Symbol symbol = checkSymbol(arg.cadr());
483                    f = get(symbol, Symbol.SETF_FUNCTION, null);
484                    if (f != null)
485                        return f;
486                    f = get(symbol, Symbol.SETF_INVERSE, null);
487                    if (f != null)
488                        return f;
489                }
490                if (car == Symbol.LAMBDA)
491                    return new Closure(arg, env);
492                if (car == Symbol.NAMED_LAMBDA) {
493                    LispObject name = arg.cadr();
494                    if (name instanceof Symbol || isValidSetfFunctionName(name)) {
495                        return new Closure(name,
496                                           new Cons(Symbol.LAMBDA, arg.cddr()),
497                                           env);
498                    }
499                    return type_error(name, FUNCTION_NAME);
500                }
501                if (car == Symbol.MACRO_FUNCTION)
502                    return new Closure(arg, env);
503            }
504            return error(new UndefinedFunction(list(Keyword.NAME, arg)));
505        }
506    };
507
508    // ### setq
509    private static final SpecialOperator SETQ = new sf_setq();
510    private static final class sf_setq extends SpecialOperator {
511        sf_setq() {
512            super(Symbol.SETQ, "&rest vars-and-values");
513        }
514
515        @Override
516        public LispObject execute(LispObject args, Environment env)
517
518        {
519            LispObject value = Nil.NIL;
520            final LispThread thread = LispThread.currentThread();
521            while (args != NIL) {
522                Symbol symbol = checkSymbol(args.car());
523                if (symbol.isConstant()) {
524                    return error(new ProgramError(symbol.princToString() +
525                                                  " is a constant and thus cannot be set."));
526                }
527                args = args.cdr();
528                if (symbol.isSpecialVariable() || env.isDeclaredSpecial(symbol)) {
529                    SpecialBinding binding = thread.getSpecialBinding(symbol);
530                    value = eval(args.car(), env, thread);
531                    if (binding != null) {
532                        binding.value = value;
533                    } else {
534                        symbol.setSymbolValue(value);
535                    }
536                } else {
537                    // Not special.
538                    Binding binding = env.getBinding(symbol);
539                    if (binding != null) {
540                        if (binding.value instanceof SymbolMacro) {
541                            LispObject expansion =
542                                ((SymbolMacro)binding.value).getExpansion();
543                            LispObject form = list(Symbol.SETF, expansion, args.car());
544                            value = eval(form, env, thread);
545                        } else {
546                            value = eval(args.car(), env, thread);
547                            binding.value = value;
548                        }
549                    } else {
550                        if (symbol.getSymbolMacro() != null) {
551                            LispObject expansion =
552                                symbol.getSymbolMacro().getExpansion();
553                            LispObject form = list(Symbol.SETF, expansion, args.car());
554                            value = eval(form, env, thread);
555                        } else {
556                            value = eval(args.car(), env, thread);
557                            symbol.setSymbolValue(value);
558                        }
559                    }
560                }
561                args = args.cdr();
562            }
563            // Return primary value only!
564            thread._values = null;
565            return value;
566        }
567    };
568}
Note: See TracBrowser for help on using the repository browser.