Changeset 12457


Ignore:
Timestamp:
02/13/10 15:42:13 (11 years ago)
Author:
vvoutilainen
Message:

Reindentation.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/SpecialOperators.java

    r12456 r12457  
    3838import java.util.ArrayList;
    3939import java.util.LinkedList;
    40 public final class SpecialOperators
    41 {
    42   // ### quote
    43   private static final SpecialOperator QUOTE = new sf_quote();
    44   private static final class sf_quote extends SpecialOperator {
    45       sf_quote()
    46       {
    47         super(Symbol.QUOTE, "thing");
    48       }
    49  
    50       @Override
    51       public LispObject execute(LispObject args, Environment env)
    52 
    53       {
    54         if (args.cdr() != NIL)
    55           return error(new WrongNumberOfArgumentsException(this));
    56         return args.car();
    57       }
    58     };
    59 
    60   // ### if
    61   private static final SpecialOperator IF = new sf_if();
    62   private static final class sf_if extends SpecialOperator {
    63       sf_if()
    64       {
    65         super(Symbol.IF, "test then &optional else");
    66       }
    67  
    68       @Override
    69       public LispObject execute(LispObject args, Environment env)
    70 
    71       {
    72         final LispThread thread = LispThread.currentThread();
    73         switch (args.length())
    74           {
    75           case 2:
    76             {
    77               if (eval(((Cons)args).car, env, thread) != NIL)
    78                 return eval(args.cadr(), env, thread);
    79               thread.clearValues();
    80               return NIL;
    81             }
    82           case 3:
    83             {
    84               if (eval(((Cons)args).car, env, thread) != NIL)
    85                 return eval(args.cadr(), env, thread);
    86               return eval((((Cons)args).cdr).cadr(), env, thread);
    87             }
    88           default:
    89             return error(new WrongNumberOfArgumentsException(this));
    90           }
    91       }
    92     };
    93 
    94   // ### let
    95   private static final SpecialOperator LET = new sf_let();
    96   private static final class sf_let extends SpecialOperator {
    97       sf_let()
    98       {
    99         super(Symbol.LET, "bindings &body body");
    100       }
    101  
    102       @Override
    103       public LispObject execute(LispObject args, Environment env)
    104 
    105       {
    106         if (args == NIL)
    107           return error(new WrongNumberOfArgumentsException(this));
    108         return _let(args, env, false);
    109       }
    110     };
    111 
    112   // ### let*
    113   private static final SpecialOperator LET_STAR = new sf_let_star();
    114   private static final class sf_let_star extends SpecialOperator {
    115       sf_let_star()
    116       {
    117         super(Symbol.LET_STAR, "bindings &body body");
    118       }
    119  
    120       @Override
    121       public LispObject execute(LispObject args, Environment env)
    122 
    123       {
    124         if (args == NIL)
    125           return error(new WrongNumberOfArgumentsException(this));
    126         return _let(args, env, true);
    127       }
    128     };
    129 
    130   private static final LispObject _let(LispObject args, Environment env,
    131                                        boolean sequential)
    132 
    133   {
    134     final LispThread thread = LispThread.currentThread();
    135     final SpecialBindingsMark mark = thread.markSpecialBindings();
    136     try
    137       {
    138         LispObject varList = checkList(args.car());
    139         LispObject bodyAndDecls = parseBody(args.cdr(), false);
    140         LispObject specials = parseSpecials(bodyAndDecls.NTH(1));
    141         LispObject body = bodyAndDecls.car();
    142 
    143         Environment ext = new Environment(env);
    144         LinkedList<Cons> nonSequentialVars = new LinkedList<Cons>();
    145         while (varList != NIL)
    146           {
    147             final Symbol symbol;
    148             LispObject value;
    149             LispObject obj = varList.car();
    150             if (obj instanceof Cons)
    151               {
    152                 if (obj.length() > 2)
    153                   return error(new LispError("The " + (sequential ? "LET*" : "LET")
    154                           + " binding specification " +
    155                           obj.writeToString() + " is invalid."));
    156                 symbol = checkSymbol(((Cons)obj).car);
    157                 value = eval(obj.cadr(), sequential ? ext : env, thread);
    158               }
    159             else
    160               {
    161                 symbol = checkSymbol(obj);
    162                 value = NIL;
    163               }
    164             if (sequential) {
    165         ext = new Environment(ext);
    166               bindArg(specials, symbol, value, ext, thread);
    167       }
    168             else
    169                 nonSequentialVars.add(new Cons(symbol, value));
    170             varList = ((Cons)varList).cdr;
    171           }
    172         if (!sequential)
    173           for (Cons x : nonSequentialVars)
    174             bindArg(specials, (Symbol)x.car(), x.cdr(), ext, thread);
    175 
    176         // Make sure free special declarations are visible in the body.
    177         // "The scope of free declarations specifically does not include
    178         // initialization forms for bindings established by the form
    179         // containing the declarations." (3.3.4)
    180         for (; specials != NIL; specials = specials.cdr())
    181           ext.declareSpecial((Symbol)specials.car());
    182 
    183         return progn(body, ext, thread);
    184       }
    185     finally
    186       {
    187         thread.resetSpecialBindings(mark);
    188       }
    189   }
    190 
    191   // ### symbol-macrolet
    192   private static final SpecialOperator SYMBOL_MACROLET = new sf_symbol_macrolet();
    193   private static final class sf_symbol_macrolet extends SpecialOperator {
    194       sf_symbol_macrolet()
    195       {
    196         super(Symbol.SYMBOL_MACROLET, "macrobindings &body body");
    197       }
    198  
    199       @Override
    200       public LispObject execute(LispObject args, Environment env)
    201 
    202       {
    203         LispObject varList = checkList(args.car());
     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));
     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));
     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));
     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));
     118            return _let(args, env, true);
     119        }
     120    };
     121
     122    private static final LispObject _let(LispObject args, Environment env,
     123                                         boolean sequential)
     124
     125    {
    204126        final LispThread thread = LispThread.currentThread();
    205127        final SpecialBindingsMark mark = thread.markSpecialBindings();
    206         Environment ext = new Environment(env);
    207         try
    208          {
    209              // Declare our free specials, this will correctly raise
    210              LispObject body = ext.processDeclarations(args.cdr());
    211 
    212              for (int i = varList.length(); i-- > 0;)
    213                {
    214                  LispObject obj = varList.car();
    215                  varList = varList.cdr();
    216                  if (obj instanceof Cons && obj.length() == 2)
    217                    {
    218                      Symbol symbol = checkSymbol(obj.car());
    219                      if (symbol.isSpecialVariable()
    220                          || ext.isDeclaredSpecial(symbol))
    221                        {
    222                           return error(new ProgramError(
    223                               "Attempt to bind the special variable " +
    224                               symbol.writeToString() +
    225                               " with SYMBOL-MACROLET."));
    226                        }
    227                      bindArg(null, symbol, new SymbolMacro(obj.cadr()), ext, thread);
    228                    }
    229                  else
    230                    {
    231                      return error(new ProgramError(
    232                        "Malformed symbol-expansion pair in SYMBOL-MACROLET: " +
    233                        obj.writeToString()));
    234                    }
    235                 }
    236              return progn(body, ext, thread);
    237               }
    238         finally
    239             {
    240               thread.resetSpecialBindings(mark);
    241             }
    242       }
    243     };
    244 
    245   // ### load-time-value form &optional read-only-p => object
    246   private static final SpecialOperator LOAD_TIME_VALUE = new sf_load_time_value();
    247   private static final class sf_load_time_value extends SpecialOperator {
    248       sf_load_time_value()
    249       {
    250         super(Symbol.LOAD_TIME_VALUE,
    251                         "form &optional read-only-p");
    252       }
    253  
    254       @Override
    255       public LispObject execute(LispObject args, Environment env)
    256 
    257       {
    258         switch (args.length())
    259           {
    260           case 1:
    261           case 2:
    262             return eval(args.car(), new Environment(),
    263                         LispThread.currentThread());
    264           default:
    265             return error(new WrongNumberOfArgumentsException(this));
    266           }
    267       }
    268     };
    269 
    270   // ### locally
    271   private static final SpecialOperator LOCALLY = new sf_locally();
    272   private static final class sf_locally extends SpecialOperator {
    273       sf_locally()
    274       {
    275         super(Symbol.LOCALLY, "&body body");
    276       }
    277  
    278       @Override
    279       public LispObject execute(LispObject args, Environment env)
    280 
    281       {
     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.writeToString() + " 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.writeToString() +
     205                                             " with SYMBOL-MACROLET."));
     206                        }
     207                        bindArg(null, symbol, new SymbolMacro(obj.cadr()), ext, thread);
     208                    } else {
     209                        return error(new ProgramError(
     210                                         "Malformed symbol-expansion pair in SYMBOL-MACROLET: " +
     211                                         obj.writeToString()));
     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));
     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    private 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());
    282315        final LispThread thread = LispThread.currentThread();
    283         final Environment ext = new Environment(env);
    284         args = ext.processDeclarations(args);
    285         return progn(args, ext, thread);
    286       }
    287     };
    288 
    289   // ### progn
    290   private static final SpecialOperator PROGN = new sf_progn();
    291   private static final class sf_progn extends SpecialOperator {
    292       sf_progn()
    293       {
    294         super(Symbol.PROGN, "&rest forms");
    295       }
    296  
    297       @Override
    298       public LispObject execute(LispObject args, Environment env)
    299 
    300       {
    301         LispThread thread = LispThread.currentThread();
    302         return progn(args, env, thread);
    303       }
    304     };
    305 
    306   // ### flet
    307   private static final SpecialOperator FLET = new sf_flet();
    308   private static final class sf_flet extends SpecialOperator {
    309       sf_flet()
    310       {
    311         super(Symbol.FLET, "definitions &body body");
    312       }
    313  
    314       @Override
    315       public LispObject execute(LispObject args, Environment env)
    316 
    317       {
    318         return _flet(args, env, false);
    319       }
    320     };
    321 
    322   // ### labels
    323   private static final SpecialOperator LABELS = new sf_labels();
    324   private static final class sf_labels extends SpecialOperator {
    325       sf_labels()
    326       {
    327         super(Symbol.LABELS, "definitions &body body");
    328       }
    329  
    330       @Override
    331       public LispObject execute(LispObject args, Environment env)
    332 
    333       {
    334         return _flet(args, env, true);
    335       }
    336     };
    337 
    338   private static final LispObject _flet(LispObject args, Environment env,
    339                                         boolean recursive)
    340 
    341   {
    342     // First argument is a list of local function definitions.
    343     LispObject defs = checkList(args.car());
    344     final LispThread thread = LispThread.currentThread();
    345     final SpecialBindingsMark mark = thread.markSpecialBindings();
    346     final Environment funEnv = new Environment(env);
    347     while (defs != NIL)
    348       {
    349         final LispObject def = checkList(defs.car());
    350         final LispObject name = def.car();
    351         final Symbol symbol;
    352         if (name instanceof Symbol)
    353           {
    354             symbol = checkSymbol(name);
    355             if (symbol.getSymbolFunction() instanceof SpecialOperator)
    356               {
    357                 String message =
    358                   symbol.getName() + " is a special operator and may not be redefined";
    359                 return error(new ProgramError(message));
    360               }
    361           }
    362         else if (isValidSetfFunctionName(name))
    363           symbol = checkSymbol(name.cadr());
    364         else
    365           return type_error(name, FUNCTION_NAME);
    366         LispObject rest = def.cdr();
    367         LispObject parameters = rest.car();
    368         LispObject body = rest.cdr();
    369         LispObject decls = NIL;
    370         while (body.car() instanceof Cons && body.car().car() == Symbol.DECLARE)
    371           {
    372             decls = new Cons(body.car(), decls);
    373             body = body.cdr();
    374           }
    375         body = new Cons(symbol, body);
    376         body = new Cons(Symbol.BLOCK, body);
    377         body = new Cons(body, NIL);
    378         while (decls != NIL)
    379           {
    380             body = new Cons(decls.car(), body);
    381             decls = decls.cdr();
    382           }
    383         LispObject lambda_expression =
    384           new Cons(Symbol.LAMBDA, new Cons(parameters, body));
    385         LispObject lambda_name =
    386           list(recursive ? Symbol.LABELS : Symbol.FLET, name);
    387         Closure closure =
    388           new Closure(lambda_name, lambda_expression,
    389                       recursive ? funEnv : env);
    390         funEnv.addFunctionBinding(name, closure);
    391         defs = defs.cdr();
    392       }
    393     try
    394       {
    395         final Environment ext = new Environment(funEnv);
    396         LispObject body = args.cdr();
    397         body = ext.processDeclarations(body);
    398         return progn(body, ext, thread);
    399       }
    400     finally
    401       {
    402         thread.resetSpecialBindings(mark);
    403       }
    404   }
    405 
    406   // ### the value-type form => result*
    407   private static final SpecialOperator THE = new sf_the();
    408   private static final class sf_the extends SpecialOperator {
    409       sf_the()
    410       {
    411         super(Symbol.THE, "type value");
    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));
    420         LispObject rv = eval(args.cadr(), env, LispThread.currentThread());
    421 
    422         // check only the most simple types: single symbols
    423         // (class type specifiers/primitive types)
    424         // DEFTYPE-d types need expansion;
    425         // doing so would slow down our execution too much
    426 
    427         // An implementation is allowed not to check the type,
    428         // the fact that we do so here is mainly driven by the
    429         // requirement to verify argument types in structure-slot
    430         // accessors (defstruct.lisp)
    431 
    432         // The policy below is in line with the level of verification
    433         // in the compiler at *safety* levels below 3
    434         LispObject type = args.car();
    435         if ((type instanceof Symbol
    436              && get(type, Symbol.DEFTYPE_DEFINITION) == NIL)
    437             || type instanceof BuiltInClass)
    438     if (rv.typep(type) == NIL)
    439         type_error(rv, type);
    440 
    441         return rv;
    442       }
    443     };
    444 
    445   // ### progv
    446   private static final SpecialOperator PROGV = new sf_progv();
    447   private static final class sf_progv extends SpecialOperator {
    448       sf_progv()
    449       {
    450         super(Symbol.PROGV, "symbols values &body body");
    451       }
    452  
    453       @Override
    454       public LispObject execute(LispObject args, Environment env)
    455 
    456       {
    457         if (args.length() < 2)
    458           return error(new WrongNumberOfArgumentsException(this));
    459         final LispThread thread = LispThread.currentThread();
    460         final LispObject symbols = checkList(eval(args.car(), env, thread));
    461         LispObject values = checkList(eval(args.cadr(), env, thread));
    462316        final SpecialBindingsMark mark = thread.markSpecialBindings();
    463         try
    464           {
    465             // Set up the new bindings.
    466             progvBindVars(symbols, values, thread);
    467             // Implicit PROGN.
    468             return progn(args.cdr().cdr(), env, thread);
    469           }
    470         finally
    471           {
     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 {
    472365            thread.resetSpecialBindings(mark);
    473           }
    474       }
    475     };
    476 
    477   // ### declare
    478   private static final SpecialOperator DECLARE = new sf_declare();
    479   private static final class sf_declare extends SpecialOperator {
    480       sf_declare()
    481       {
    482         super(Symbol.DECLARE, "&rest declaration-specifiers");
    483       }
    484  
    485       @Override
    486       public LispObject execute(LispObject args, Environment env)
    487 
    488       {
    489         return NIL;
    490       }
    491     };
    492 
    493   // ### function
    494   private static final SpecialOperator FUNCTION = new sf_function();
    495   private static final class sf_function extends SpecialOperator {
    496       sf_function()
    497       {
    498         super(Symbol.FUNCTION, "thing");
    499       }
    500  
    501       @Override
    502       public LispObject execute(LispObject args, Environment env)
    503 
    504       {
    505         final LispObject arg = args.car();
    506         if (arg instanceof Symbol)
    507           {
    508             LispObject operator = env.lookupFunction(arg);
    509             if (operator instanceof Autoload)
    510               {
    511                 Autoload autoload = (Autoload) operator;
    512                 autoload.load();
    513                 operator = autoload.getSymbol().getSymbolFunction();
    514               }
    515             if (operator instanceof Function)
    516               return operator;
    517             if (operator instanceof StandardGenericFunction)
    518               return operator;
    519             return error(new UndefinedFunction(arg));
    520           }
    521         if (arg instanceof Cons)
    522           {
    523             LispObject car = ((Cons)arg).car;
    524             if (car == Symbol.SETF)
    525               {
    526                 LispObject f = env.lookupFunction(arg);
    527                 if (f != null)
    528                   return f;
    529                 Symbol symbol = checkSymbol(arg.cadr());
    530                 f = get(symbol, Symbol.SETF_FUNCTION, null);
    531                 if (f != null)
    532                   return f;
    533                 f = get(symbol, Symbol.SETF_INVERSE, null);
    534                 if (f != null)
    535                   return f;
    536               }
    537             if (car == Symbol.LAMBDA)
    538               return new Closure(arg, env);
    539             if (car == Symbol.NAMED_LAMBDA)
    540               {
    541                 LispObject name = arg.cadr();
    542                 if (name instanceof Symbol || isValidSetfFunctionName(name))
    543                   {
    544                     return new Closure(name,
    545                                        new Cons(Symbol.LAMBDA, arg.cddr()),
    546                                        env);
    547                   }
    548                 return type_error(name, FUNCTION_NAME);
    549               }
    550           }
    551         return error(new UndefinedFunction(list(Keyword.NAME, arg)));
    552       }
    553     };
    554 
    555   // ### setq
    556   private static final SpecialOperator SETQ = new sf_setq();
    557   private static final class sf_setq extends SpecialOperator {
    558       sf_setq()
    559       {
    560         super(Symbol.SETQ, "&rest vars-and-values");
    561       }
    562  
    563       @Override
    564       public LispObject execute(LispObject args, Environment env)
    565 
    566       {
    567         LispObject value = Nil.NIL;
    568         final LispThread thread = LispThread.currentThread();
    569         while (args != NIL)
    570           {
    571             Symbol symbol = checkSymbol(args.car());
    572             if (symbol.isConstant())
    573               {
    574                 return error(new ProgramError(symbol.writeToString() +
    575                                                " is a constant and thus cannot be set."));
    576               }
    577             args = args.cdr();
    578             if (symbol.isSpecialVariable() || env.isDeclaredSpecial(symbol))
    579               {
    580                 SpecialBinding binding = thread.getSpecialBinding(symbol);
    581                 if (binding != null)
    582                   {
    583                     if (binding.value instanceof SymbolMacro)
    584                       {
    585                         LispObject expansion =
    586                           ((SymbolMacro)binding.value).getExpansion();
    587                         LispObject form = list(Symbol.SETF, expansion, args.car());
    588                         value = eval(form, env, thread);
    589                       }
    590                     else
    591                       {
    592                         value = eval(args.car(), env, thread);
    593                         binding.value = value;
    594                       }
    595                   }
    596                 else
    597                   {
    598                     if (symbol.getSymbolValue() instanceof SymbolMacro)
    599                       {
    600                         LispObject expansion =
    601                           ((SymbolMacro)symbol.getSymbolValue()).getExpansion();
    602                         LispObject form = list(Symbol.SETF, expansion, args.car());
    603                         value = eval(form, env, thread);
    604                       }
    605                     else
    606                       {
    607                         value = eval(args.car(), env, thread);
    608                         symbol.setSymbolValue(value);
    609                       }
    610                   }
    611               }
    612             else
    613               {
    614                 // Not special.
    615                 Binding binding = env.getBinding(symbol);
    616                 if (binding != null)
    617                   {
    618                     if (binding.value instanceof SymbolMacro)
    619                       {
    620                         LispObject expansion =
    621                           ((SymbolMacro)binding.value).getExpansion();
    622                         LispObject form = list(Symbol.SETF, expansion, args.car());
    623                         value = eval(form, env, thread);
    624                       }
    625                     else
    626                       {
    627                         value = eval(args.car(), env, thread);
    628                         binding.value = value;
    629                       }
    630                   }
    631                 else
    632                   {
    633                     if (symbol.getSymbolValue() instanceof SymbolMacro)
    634                       {
    635                         LispObject expansion =
    636                           ((SymbolMacro)symbol.getSymbolValue()).getExpansion();
    637                         LispObject form = list(Symbol.SETF, expansion, args.car());
    638                         value = eval(form, env, thread);
    639                       }
    640                     else
    641                       {
    642                         value = eval(args.car(), env, thread);
    643                         symbol.setSymbolValue(value);
    644                       }
    645                   }
    646               }
    647             args = args.cdr();
    648           }
    649         // Return primary value only!
    650         thread._values = null;
    651         return value;
    652       }
     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));
     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));
     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            }
     502            return error(new UndefinedFunction(list(Keyword.NAME, arg)));
     503        }
     504    };
     505
     506    // ### setq
     507    private static final SpecialOperator SETQ = new sf_setq();
     508    private static final class sf_setq extends SpecialOperator {
     509        sf_setq() {
     510            super(Symbol.SETQ, "&rest vars-and-values");
     511        }
     512
     513        @Override
     514        public LispObject execute(LispObject args, Environment env)
     515
     516        {
     517            LispObject value = Nil.NIL;
     518            final LispThread thread = LispThread.currentThread();
     519            while (args != NIL) {
     520                Symbol symbol = checkSymbol(args.car());
     521                if (symbol.isConstant()) {
     522                    return error(new ProgramError(symbol.writeToString() +
     523                                                  " is a constant and thus cannot be set."));
     524                }
     525                args = args.cdr();
     526                if (symbol.isSpecialVariable() || env.isDeclaredSpecial(symbol)) {
     527                    SpecialBinding binding = thread.getSpecialBinding(symbol);
     528                    if (binding != null) {
     529                        if (binding.value instanceof SymbolMacro) {
     530                            LispObject expansion =
     531                                ((SymbolMacro)binding.value).getExpansion();
     532                            LispObject form = list(Symbol.SETF, expansion, args.car());
     533                            value = eval(form, env, thread);
     534                        } else {
     535                            value = eval(args.car(), env, thread);
     536                            binding.value = value;
     537                        }
     538                    } else {
     539                        if (symbol.getSymbolValue() instanceof SymbolMacro) {
     540                            LispObject expansion =
     541                                ((SymbolMacro)symbol.getSymbolValue()).getExpansion();
     542                            LispObject form = list(Symbol.SETF, expansion, args.car());
     543                            value = eval(form, env, thread);
     544                        } else {
     545                            value = eval(args.car(), env, thread);
     546                            symbol.setSymbolValue(value);
     547                        }
     548                    }
     549                } else {
     550                    // Not special.
     551                    Binding binding = env.getBinding(symbol);
     552                    if (binding != null) {
     553                        if (binding.value instanceof SymbolMacro) {
     554                            LispObject expansion =
     555                                ((SymbolMacro)binding.value).getExpansion();
     556                            LispObject form = list(Symbol.SETF, expansion, args.car());
     557                            value = eval(form, env, thread);
     558                        } else {
     559                            value = eval(args.car(), env, thread);
     560                            binding.value = value;
     561                        }
     562                    } else {
     563                        if (symbol.getSymbolValue() instanceof SymbolMacro) {
     564                            LispObject expansion =
     565                                ((SymbolMacro)symbol.getSymbolValue()).getExpansion();
     566                            LispObject form = list(Symbol.SETF, expansion, args.car());
     567                            value = eval(form, env, thread);
     568                        } else {
     569                            value = eval(args.car(), env, thread);
     570                            symbol.setSymbolValue(value);
     571                        }
     572                    }
     573                }
     574                args = args.cdr();
     575            }
     576            // Return primary value only!
     577            thread._values = null;
     578            return value;
     579        }
    653580    };
    654581}
Note: See TracChangeset for help on using the changeset viewer.