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