Many resources are needed to download a project. Please understand that we have to compensate our server costs. Thank you in advance. Project price only 1 $
You can buy this project and download/modify it how often you want.
/*
* SpecialOperators.java
*
* Copyright (C) 2003-2007 Peter Graves
* $Id$
*
* This program is free software; you can redistribute it and/or
* modify it under the terms of the GNU General Public License
* as published by the Free Software Foundation; either version 2
* of the License, or (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
*
* As a special exception, the copyright holders of this library give you
* permission to link this library with independent modules to produce an
* executable, regardless of the license terms of these independent
* modules, and to copy and distribute the resulting executable under
* terms of your choice, provided that you also meet, for each linked
* independent module, the terms and conditions of the license of that
* module. An independent module is a module which is not derived from
* or based on this library. If you modify this library, you may extend
* this exception to your version of the library, but you are not
* obligated to do so. If you do not wish to do so, delete this
* exception statement from your version.
*/
package org.armedbear.lisp;
import static org.armedbear.lisp.Lisp.*;
import java.util.ArrayList;
import java.util.LinkedList;
public final class SpecialOperators {
// ### quote
private static final SpecialOperator QUOTE = new sf_quote();
private static final class sf_quote extends SpecialOperator {
sf_quote() {
super(Symbol.QUOTE, "thing");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
if (args.cdr() != NIL)
return error(new WrongNumberOfArgumentsException(this, 1));
return args.car();
}
};
// ### if
private static final SpecialOperator IF = new sf_if();
private static final class sf_if extends SpecialOperator {
sf_if() {
super(Symbol.IF, "test then &optional else");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
final LispThread thread = LispThread.currentThread();
switch (args.length()) {
case 2: {
if (eval(((Cons)args).car, env, thread) != NIL)
return eval(args.cadr(), env, thread);
thread.clearValues();
return NIL;
}
case 3: {
if (eval(((Cons)args).car, env, thread) != NIL)
return eval(args.cadr(), env, thread);
return eval((((Cons)args).cdr).cadr(), env, thread);
}
default:
return error(new WrongNumberOfArgumentsException(this, 2, 3));
}
}
};
// ### let
private static final SpecialOperator LET = new sf_let();
private static final class sf_let extends SpecialOperator {
sf_let() {
super(Symbol.LET, "bindings &body body");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
if (args == NIL)
return error(new WrongNumberOfArgumentsException(this, 1, -1));
return _let(args, env, false);
}
};
// ### let*
private static final SpecialOperator LET_STAR = new sf_let_star();
private static final class sf_let_star extends SpecialOperator {
sf_let_star() {
super(Symbol.LET_STAR, "bindings &body body");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
if (args == NIL)
return error(new WrongNumberOfArgumentsException(this, 1, -1));
return _let(args, env, true);
}
};
static final LispObject _let(LispObject args, Environment env,
boolean sequential)
{
final LispThread thread = LispThread.currentThread();
final SpecialBindingsMark mark = thread.markSpecialBindings();
try {
LispObject varList = checkList(args.car());
LispObject bodyAndDecls = parseBody(args.cdr(), false);
LispObject specials = parseSpecials(bodyAndDecls.NTH(1));
LispObject body = bodyAndDecls.car();
Environment ext = new Environment(env);
LinkedList nonSequentialVars = new LinkedList();
while (varList != NIL) {
final Symbol symbol;
LispObject value;
LispObject obj = varList.car();
if (obj instanceof Cons) {
if (obj.length() > 2)
return error(new LispError("The " + (sequential ? "LET*" : "LET")
+ " binding specification " +
obj.princToString() + " is invalid."));
symbol = checkSymbol(((Cons)obj).car);
value = eval(obj.cadr(), sequential ? ext : env, thread);
} else {
symbol = checkSymbol(obj);
value = NIL;
}
if (sequential) {
ext = new Environment(ext);
bindArg(specials, symbol, value, ext, thread);
} else
nonSequentialVars.add(new Cons(symbol, value));
varList = ((Cons)varList).cdr;
}
if (!sequential)
for (Cons x : nonSequentialVars)
bindArg(specials, (Symbol)x.car(), x.cdr(), ext, thread);
// Make sure free special declarations are visible in the body.
// "The scope of free declarations specifically does not include
// initialization forms for bindings established by the form
// containing the declarations." (3.3.4)
for (; specials != NIL; specials = specials.cdr())
ext.declareSpecial((Symbol)specials.car());
return progn(body, ext, thread);
}
finally {
thread.resetSpecialBindings(mark);
}
}
// ### symbol-macrolet
private static final SpecialOperator SYMBOL_MACROLET = new sf_symbol_macrolet();
private static final class sf_symbol_macrolet extends SpecialOperator {
sf_symbol_macrolet() {
super(Symbol.SYMBOL_MACROLET, "macrobindings &body body");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
LispObject varList = checkList(args.car());
final LispThread thread = LispThread.currentThread();
final SpecialBindingsMark mark = thread.markSpecialBindings();
Environment ext = new Environment(env);
try {
// Declare our free specials, this will correctly raise
LispObject body = ext.processDeclarations(args.cdr());
for (int i = varList.length(); i-- > 0;) {
LispObject obj = varList.car();
varList = varList.cdr();
if (obj instanceof Cons && obj.length() == 2) {
Symbol symbol = checkSymbol(obj.car());
if (symbol.isSpecialVariable()
|| ext.isDeclaredSpecial(symbol)) {
return program_error("Attempt to bind the special variable "
+ symbol.princToString()
+ " with SYMBOL-MACROLET.");
}
ext.bind(symbol, new SymbolMacro(obj.cadr()));
} else {
return program_error("Malformed symbol-expansion pair in SYMBOL-MACROLET: "
+ obj.princToString() + ".");
}
}
return progn(body, ext, thread);
}
finally {
thread.resetSpecialBindings(mark);
}
}
};
// ### load-time-value form &optional read-only-p => object
private static final SpecialOperator LOAD_TIME_VALUE = new sf_load_time_value();
private static final class sf_load_time_value extends SpecialOperator {
sf_load_time_value() {
super(Symbol.LOAD_TIME_VALUE,
"form &optional read-only-p");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
switch (args.length()) {
case 1:
case 2:
return eval(args.car(), new Environment(),
LispThread.currentThread());
default:
return error(new WrongNumberOfArgumentsException(this, 1, 2));
}
}
};
// ### locally
private static final SpecialOperator LOCALLY = new sf_locally();
private static final class sf_locally extends SpecialOperator {
sf_locally() {
super(Symbol.LOCALLY, "&body body");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
final LispThread thread = LispThread.currentThread();
final Environment ext = new Environment(env);
args = ext.processDeclarations(args);
return progn(args, ext, thread);
}
};
// ### progn
private static final SpecialOperator PROGN = new sf_progn();
private static final class sf_progn extends SpecialOperator {
sf_progn() {
super(Symbol.PROGN, "&rest forms");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
LispThread thread = LispThread.currentThread();
return progn(args, env, thread);
}
};
// ### flet
private static final SpecialOperator FLET = new sf_flet();
private static final class sf_flet extends SpecialOperator {
sf_flet() {
super(Symbol.FLET, "definitions &body body");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
return _flet(args, env, false);
}
};
// ### labels
private static final SpecialOperator LABELS = new sf_labels();
private static final class sf_labels extends SpecialOperator {
sf_labels() {
super(Symbol.LABELS, "definitions &body body");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
return _flet(args, env, true);
}
};
static final LispObject _flet(LispObject args, Environment env,
boolean recursive)
{
// First argument is a list of local function definitions.
LispObject defs = checkList(args.car());
final LispThread thread = LispThread.currentThread();
final SpecialBindingsMark mark = thread.markSpecialBindings();
final Environment funEnv = new Environment(env);
while (defs != NIL) {
final LispObject def = checkList(defs.car());
final LispObject name = def.car();
final Symbol symbol;
if (name instanceof Symbol) {
symbol = checkSymbol(name);
if (symbol.getSymbolFunction() instanceof SpecialOperator) {
return program_error(symbol.getName()
+ " is a special operator and may not be redefined.");
}
} else if (isValidSetfFunctionName(name))
symbol = checkSymbol(name.cadr());
else
return type_error(name, FUNCTION_NAME);
LispObject rest = def.cdr();
LispObject parameters = rest.car();
LispObject body = rest.cdr();
LispObject decls = NIL;
while (body.car() instanceof Cons && body.car().car() == Symbol.DECLARE) {
decls = new Cons(body.car(), decls);
body = body.cdr();
}
body = new Cons(symbol, body);
body = new Cons(Symbol.BLOCK, body);
body = new Cons(body, NIL);
while (decls != NIL) {
body = new Cons(decls.car(), body);
decls = decls.cdr();
}
LispObject lambda_expression =
new Cons(Symbol.LAMBDA, new Cons(parameters, body));
LispObject lambda_name =
list(recursive ? Symbol.LABELS : Symbol.FLET, name);
Closure closure =
new Closure(lambda_name, lambda_expression,
recursive ? funEnv : env);
funEnv.addFunctionBinding(name, closure);
defs = defs.cdr();
}
try {
final Environment ext = new Environment(funEnv);
LispObject body = args.cdr();
body = ext.processDeclarations(body);
return progn(body, ext, thread);
}
finally {
thread.resetSpecialBindings(mark);
}
}
// ### the value-type form => result*
private static final SpecialOperator THE = new sf_the();
private static final class sf_the extends SpecialOperator {
sf_the() {
super(Symbol.THE, "type value");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
if (args.length() != 2)
return error(new WrongNumberOfArgumentsException(this, 2));
LispObject rv = eval(args.cadr(), env, LispThread.currentThread());
// check only the most simple types: single symbols
// (class type specifiers/primitive types)
// DEFTYPE-d types need expansion;
// doing so would slow down our execution too much
// An implementation is allowed not to check the type,
// the fact that we do so here is mainly driven by the
// requirement to verify argument types in structure-slot
// accessors (defstruct.lisp)
// The policy below is in line with the level of verification
// in the compiler at *safety* levels below 3
LispObject type = args.car();
if ((type instanceof Symbol
&& get(type, Symbol.DEFTYPE_DEFINITION) == NIL)
|| type instanceof BuiltInClass)
if (rv.typep(type) == NIL)
type_error(rv, type);
return rv;
}
};
// ### progv
private static final SpecialOperator PROGV = new sf_progv();
private static final class sf_progv extends SpecialOperator {
sf_progv() {
super(Symbol.PROGV, "symbols values &body body");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
if (args.length() < 2)
return error(new WrongNumberOfArgumentsException(this, 2, -1));
final LispThread thread = LispThread.currentThread();
final LispObject symbols = checkList(eval(args.car(), env, thread));
LispObject values = checkList(eval(args.cadr(), env, thread));
final SpecialBindingsMark mark = thread.markSpecialBindings();
try {
// Set up the new bindings.
progvBindVars(symbols, values, thread);
// Implicit PROGN.
return progn(args.cdr().cdr(), env, thread);
}
finally {
thread.resetSpecialBindings(mark);
}
}
};
// ### declare
private static final SpecialOperator DECLARE = new sf_declare();
private static final class sf_declare extends SpecialOperator {
sf_declare() {
super(Symbol.DECLARE, "&rest declaration-specifiers");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
return NIL;
}
};
// ### function
private static final SpecialOperator FUNCTION = new sf_function();
private static final class sf_function extends SpecialOperator {
sf_function() {
super(Symbol.FUNCTION, "thing");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
final LispObject arg = args.car();
if (arg instanceof Symbol) {
LispObject operator = env.lookupFunction(arg);
if (operator instanceof Autoload) {
Autoload autoload = (Autoload) operator;
autoload.load();
operator = autoload.getSymbol().getSymbolFunction();
}
if (operator instanceof Function)
return operator;
if (operator instanceof FuncallableStandardObject)
return operator;
return error(new UndefinedFunction(arg));
}
if (arg instanceof Cons) {
LispObject car = ((Cons)arg).car;
if (car == Symbol.SETF) {
LispObject f = env.lookupFunction(arg);
if (f != null)
return f;
Symbol symbol = checkSymbol(arg.cadr());
f = get(symbol, Symbol.SETF_FUNCTION, null);
if (f != null)
return f;
f = get(symbol, Symbol.SETF_INVERSE, null);
if (f != null)
return f;
}
if (car == Symbol.LAMBDA)
return new Closure(arg, env);
if (car == Symbol.NAMED_LAMBDA) {
LispObject name = arg.cadr();
if (name instanceof Symbol || isValidSetfFunctionName(name)) {
return new Closure(name,
new Cons(Symbol.LAMBDA, arg.cddr()),
env);
}
return type_error(name, FUNCTION_NAME);
}
if (car == Symbol.MACRO_FUNCTION)
return new Closure(arg, env);
}
return error(new UndefinedFunction(list(Keyword.NAME, arg)));
}
};
// ### setq
private static final SpecialOperator SETQ = new sf_setq();
private static final class sf_setq extends SpecialOperator {
sf_setq() {
super(Symbol.SETQ, "&rest vars-and-values");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
LispObject value = Nil.NIL;
final LispThread thread = LispThread.currentThread();
while (args != NIL) {
Symbol symbol = checkSymbol(args.car());
if (symbol.isConstant()) {
return program_error(symbol.princToString()
+ " is a constant and thus cannot be set.");
}
args = args.cdr();
if (symbol.isSpecialVariable() || env.isDeclaredSpecial(symbol)) {
SpecialBinding binding = thread.getSpecialBinding(symbol);
value = eval(args.car(), env, thread);
if (binding != null) {
binding.value = value;
} else {
symbol.setSymbolValue(value);
}
} else {
// Not special.
Binding binding = env.getBinding(symbol);
if (binding != null) {
if (binding.value instanceof SymbolMacro) {
LispObject expansion =
((SymbolMacro)binding.value).getExpansion();
LispObject form = list(Symbol.SETF, expansion, args.car());
value = eval(form, env, thread);
} else {
value = eval(args.car(), env, thread);
binding.value = value;
}
} else {
if (symbol.getSymbolMacro() != null) {
LispObject expansion =
symbol.getSymbolMacro().getExpansion();
LispObject form = list(Symbol.SETF, expansion, args.car());
value = eval(form, env, thread);
} else {
value = eval(args.car(), env, thread);
symbol.setSymbolValue(value);
}
}
}
args = args.cdr();
}
// Return primary value only!
thread._values = null;
return value;
}
};
}
