source: trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java

Last change on this file was 15569, checked in by Mark Evenson, 2 years ago

Untabify en masse

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