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.
org.armedbear.lisp.Primitives Maven / Gradle / Ivy
/*
* Primitives.java
*
* Copyright (C) 2002-2007 Peter Graves
* Copyright (C) 2011 Erik Huelsmann
* $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.math.BigInteger;
import java.util.ArrayList;
import org.armedbear.lisp.util.Finalizer;
public final class Primitives {
// ### *
public static final Primitive MULTIPLY = new pf_multiply();
private static final class pf_multiply extends Primitive {
pf_multiply() {
super(Symbol.STAR, "&rest numbers");
}
@Override
public LispObject execute() {
return Fixnum.ONE;
}
@Override
public LispObject execute(LispObject arg) {
if (arg.numberp())
return arg;
return type_error(arg, Symbol.NUMBER);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.multiplyBy(second);
}
@Override
public LispObject execute(LispObject[] args) {
LispObject result = Fixnum.ONE;
for (int i = 0; i < args.length; i++)
result = result.multiplyBy(args[i]);
return result;
}
};
// ### /
public static final Primitive DIVIDE = new pf_divide();
private static final class pf_divide extends Primitive {
pf_divide() {
super(Symbol.SLASH, "numerator &rest denominators");
}
@Override
public LispObject execute() {
return error(new WrongNumberOfArgumentsException(this, 1, -1));
}
@Override
public LispObject execute(LispObject arg) {
return Fixnum.ONE.divideBy(arg);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.divideBy(second);
}
@Override
public LispObject execute(LispObject[] args) {
LispObject result = args[0];
for (int i = 1; i < args.length; i++)
result = result.divideBy(args[i]);
return result;
}
};
// ### min
public static final Primitive MIN = new pf_min();
private static final class pf_min extends Primitive {
pf_min() {
super(Symbol.MIN, "&rest reals");
}
@Override
public LispObject execute() {
return error(new WrongNumberOfArgumentsException(this, 1, -1));
}
@Override
public LispObject execute(LispObject arg) {
if (arg.realp())
return arg;
return type_error(arg, Symbol.REAL);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.isLessThan(second) ? first : second;
}
@Override
public LispObject execute(LispObject[] args) {
LispObject result = args[0];
if (!result.realp())
type_error(result, Symbol.REAL);
for (int i = 1; i < args.length; i++) {
if (args[i].isLessThan(result))
result = args[i];
}
return result;
}
};
// ### max
public static final Primitive MAX = new pf_max();
private static final class pf_max extends Primitive {
pf_max() {
super(Symbol.MAX, "&rest reals");
}
@Override
public LispObject execute() {
return error(new WrongNumberOfArgumentsException(this, 1, -1));
}
@Override
public LispObject execute(LispObject arg) {
if (arg.realp())
return arg;
return type_error(arg, Symbol.REAL);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.isGreaterThan(second) ? first : second;
}
@Override
public LispObject execute(LispObject[] args) {
LispObject result = args[0];
if (!result.realp())
type_error(result, Symbol.REAL);
for (int i = 1; i < args.length; i++) {
if (args[i].isGreaterThan(result))
result = args[i];
}
return result;
}
};
// ### identity
private static final Primitive IDENTITY = new pf_identity();
private static final class pf_identity extends Primitive {
pf_identity() {
super(Symbol.IDENTITY, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg;
}
};
// ### compiled-function-p
private static final Primitive COMPILED_FUNCTION_P = new pf_compiled_function_p();
private static final class pf_compiled_function_p extends Primitive {
pf_compiled_function_p() {
super(Symbol.COMPILED_FUNCTION_P, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg.typep(Symbol.COMPILED_FUNCTION);
}
};
// ### compiled-lisp-function-p
private static final Primitive COMPILED_LISP_FUNCTION_P =
new pf_compiled_lisp_function_p();
private static final class pf_compiled_lisp_function_p extends Primitive {
pf_compiled_lisp_function_p() {
super(Symbol.COMPILED_LISP_FUNCTION_P, "object");
}
@Override
public LispObject execute(LispObject arg) {
return (arg instanceof CompiledClosure
|| arg instanceof CompiledPrimitive) ? T : NIL;
}
}
// ### consp
private static final Primitive CONSP = new pf_consp();
private static final class pf_consp extends Primitive {
pf_consp() {
super(Symbol.CONSP, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg instanceof Cons ? T : NIL;
}
};
// ### listp
private static final Primitive LISTP = new pf_listp();
private static final class pf_listp extends Primitive {
pf_listp() {
super(Symbol.LISTP, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg.LISTP();
}
};
// ### abs
private static final Primitive ABS = new pf_abs();
private static final class pf_abs extends Primitive {
pf_abs() {
super(Symbol.ABS, "number");
}
@Override
public LispObject execute(LispObject arg) {
return arg.ABS();
}
};
// ### arrayp
private static final Primitive ARRAYP = new pf_arrayp();
private static final class pf_arrayp extends Primitive {
pf_arrayp() {
super(Symbol.ARRAYP, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg instanceof AbstractArray ? T : NIL;
}
};
// ### array-has-fill-pointer-p
private static final Primitive ARRAY_HAS_FILL_POINTER_P = new pf_array_has_fill_pointer_p();
private static final class pf_array_has_fill_pointer_p extends Primitive {
pf_array_has_fill_pointer_p() {
super(Symbol.ARRAY_HAS_FILL_POINTER_P, "array");
}
@Override
public LispObject execute(LispObject arg) {
return checkArray(arg).hasFillPointer() ? T : NIL;
}
};
// ### vectorp
private static final Primitive VECTORP = new pf_vectorp();
private static final class pf_vectorp extends Primitive {
pf_vectorp() {
super(Symbol.VECTORP, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg.VECTORP();
}
};
// ### simple-vector-p
private static final Primitive SIMPLE_VECTOR_P = new pf_simple_vector_p();
private static final class pf_simple_vector_p extends Primitive {
pf_simple_vector_p() {
super(Symbol.SIMPLE_VECTOR_P, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg instanceof SimpleVector ? T : NIL;
}
};
// ### bit-vector-p
private static final Primitive BIT_VECTOR_P = new pf_bit_vector_p();
private static final class pf_bit_vector_p extends Primitive {
pf_bit_vector_p() {
super(Symbol.BIT_VECTOR_P, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg instanceof AbstractBitVector ? T : NIL;
}
};
// ### simple-bit-vector-p
private static final Primitive SIMPLE_BIT_VECTOR_P = new pf_simple_bit_vector_p();
private static final class pf_simple_bit_vector_p extends Primitive {
pf_simple_bit_vector_p() {
super(Symbol.SIMPLE_BIT_VECTOR_P, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg.typep(Symbol.SIMPLE_BIT_VECTOR);
}
};
// ### %eval
private static final Primitive _EVAL = new pf__eval();
private static final class pf__eval extends Primitive {
pf__eval() {
super("%eval", PACKAGE_SYS, false, "form");
}
@Override
public LispObject execute(LispObject arg) {
return eval(arg, new Environment(), LispThread.currentThread());
}
};
// ### eq
private static final Primitive EQ = new pf_eq();
private static final class pf_eq extends Primitive {
pf_eq() {
super(Symbol.EQ, "x y");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first == second ? T : NIL;
}
};
// ### eql
static final Primitive EQL = new pf_eql();
private static final class pf_eql extends Primitive {
pf_eql() {
super(Symbol.EQL, "x y");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.eql(second) ? T : NIL;
}
};
// ### equal
private static final Primitive EQUAL = new pf_equal();
private static final class pf_equal extends Primitive {
pf_equal() {
super(Symbol.EQUAL, "x y");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.equal(second) ? T : NIL;
}
};
// ### equalp
private static final Primitive EQUALP = new pf_equalp();
private static final class pf_equalp extends Primitive {
pf_equalp() {
super(Symbol.EQUALP, "x y");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.equalp(second) ? T : NIL;
}
};
// ### values
public static final Primitive VALUES = new pf_values();
private static final class pf_values extends Primitive {
pf_values() {
super(Symbol.VALUES, "&rest object");
}
@Override
public LispObject execute() {
return LispThread.currentThread().setValues();
}
@Override
public LispObject execute(LispObject arg) {
return LispThread.currentThread().setValues(arg);
}
@Override
public LispObject execute(LispObject first, LispObject second) {
return LispThread.currentThread().setValues(first, second);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third) {
return LispThread.currentThread().setValues(first, second, third);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third, LispObject fourth) {
return LispThread.currentThread().setValues(first, second, third,
fourth);
}
@Override
public LispObject execute(LispObject[] args) {
return LispThread.currentThread().setValues(args);
}
};
// ### values-list list => element*
// Returns the elements of the list as multiple values.
private static final Primitive VALUES_LIST = new pf_values_list();
private static final class pf_values_list extends Primitive {
pf_values_list() {
super(Symbol.VALUES_LIST, "list");
}
@Override
public LispObject execute(LispObject arg) {
if (arg == NIL)
return LispThread.currentThread().setValues();
if (arg.cdr() == NIL)
return arg.car();
return LispThread.currentThread().setValues(arg.copyToArray());
}
};
// ### cons
private static final Primitive CONS = new pf_cons();
private static final class pf_cons extends Primitive {
pf_cons() {
super(Symbol.CONS, "object-1 object-2");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return new Cons(first, second);
}
};
// ### length
private static final Primitive LENGTH = new pf_length();
private static final class pf_length extends Primitive {
pf_length() {
super("%LENGTH", PACKAGE_SYS, false, "sequence");
}
@Override
public LispObject execute(LispObject arg) {
return arg.LENGTH();
}
};
// ### elt
private static final Primitive ELT = new pf_elt();
private static final class pf_elt extends Primitive {
pf_elt() {
super("%ELT", PACKAGE_SYS, false, "sequence index");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.elt(Fixnum.getValue(second));
}
};
// ### atom
private static final Primitive ATOM = new pf_atom();
private static final class pf_atom extends Primitive {
pf_atom() {
super(Symbol.ATOM, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg instanceof Cons ? NIL : T;
}
};
// ### constantp
private static final Primitive CONSTANTP = new pf_constantp();
private static final class pf_constantp extends Primitive {
pf_constantp() {
super(Symbol.CONSTANTP, "form &optional environment");
}
@Override
public LispObject execute(LispObject arg) {
return arg.constantp() ? T : NIL;
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.constantp() ? T : NIL;
}
};
// ### functionp
private static final Primitive FUNCTIONP = new pf_functionp();
private static final class pf_functionp extends Primitive {
pf_functionp() {
super(Symbol.FUNCTIONP, "object");
}
@Override
public LispObject execute(LispObject arg) {
return (arg instanceof Function || arg instanceof FuncallableStandardObject) ? T : NIL;
}
};
// ### special-operator-p
private static final Primitive SPECIAL_OPERATOR_P = new pf_special_operator_p();
private static final class pf_special_operator_p extends Primitive {
pf_special_operator_p() {
super(Symbol.SPECIAL_OPERATOR_P, "symbol");
}
@Override
public LispObject execute(LispObject arg) {
return arg.isSpecialOperator() ? T : NIL;
}
};
// ### symbolp
private static final Primitive SYMBOLP = new pf_symbolp();
private static final class pf_symbolp extends Primitive {
pf_symbolp() {
super(Symbol.SYMBOLP, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg instanceof Symbol ? T : NIL;
}
};
// ### endp
private static final Primitive ENDP = new pf_endp();
private static final class pf_endp extends Primitive {
pf_endp() {
super(Symbol.ENDP, "list");
}
@Override
public LispObject execute(LispObject arg) {
return arg.endp() ? T : NIL;
}
};
// ### null
private static final Primitive NULL = new pf_null();
private static final class pf_null extends Primitive {
pf_null() {
super(Symbol.NULL, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg == NIL ? T : NIL;
}
};
// ### not
private static final Primitive NOT = new pf_not();
private static final class pf_not extends Primitive {
pf_not() {
super(Symbol.NOT, "x");
}
@Override
public LispObject execute(LispObject arg) {
return arg == NIL ? T : NIL;
}
};
// ### plusp
private static final Primitive PLUSP = new pf_plusp();
private static final class pf_plusp extends Primitive {
pf_plusp() {
super(Symbol.PLUSP, "real");
}
@Override
public LispObject execute(LispObject arg) {
return arg.PLUSP();
}
};
// ### minusp
private static final Primitive MINUSP = new pf_minusp();
private static final class pf_minusp extends Primitive {
pf_minusp() {
super(Symbol.MINUSP, "real");
}
@Override
public LispObject execute(LispObject arg) {
return arg.MINUSP();
}
};
// ### zerop
private static final Primitive ZEROP = new pf_zerop();
private static final class pf_zerop extends Primitive {
pf_zerop() {
super(Symbol.ZEROP, "number");
}
@Override
public LispObject execute(LispObject arg) {
return arg.ZEROP();
}
};
// ### fixnump
private static final Primitive FIXNUMP = new pf_fixnump();
private static final class pf_fixnump extends Primitive {
pf_fixnump() {
super("fixnump", PACKAGE_EXT, true);
}
@Override
public LispObject execute(LispObject arg) {
return arg instanceof Fixnum ? T : NIL;
}
};
// ### symbol-value
private static final Primitive SYMBOL_VALUE = new pf_symbol_value();
private static final class pf_symbol_value extends Primitive {
pf_symbol_value() {
super(Symbol.SYMBOL_VALUE, "symbol");
}
@Override
public LispObject execute(LispObject arg) {
final LispObject value;
value = checkSymbol(arg).symbolValue();
return value;
}
};
// ### set symbol value => value
private static final Primitive SET = new pf_set();
private static final class pf_set extends Primitive {
pf_set() {
super(Symbol.SET, "symbol value");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return LispThread.currentThread().setSpecialVariable(checkSymbol(first),
second);
}
};
// ### rplaca
private static final Primitive RPLACA = new pf_rplaca();
private static final class pf_rplaca extends Primitive {
pf_rplaca() {
super(Symbol.RPLACA, "cons object");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
first.setCar(second);
return first;
}
};
// ### rplacd
private static final Primitive RPLACD = new pf_rplacd();
private static final class pf_rplacd extends Primitive {
pf_rplacd() {
super(Symbol.RPLACD, "cons object");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
first.setCdr(second);
return first;
}
};
// ### +
private static final Primitive ADD = new pf_add();
private static final class pf_add extends Primitive {
pf_add() {
super(Symbol.PLUS, "&rest numbers");
}
@Override
public LispObject execute() {
return Fixnum.ZERO;
}
@Override
public LispObject execute(LispObject arg) {
if (arg.numberp())
return arg;
return type_error(arg, Symbol.NUMBER);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.add(second);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
return first.add(second).add(third);
}
@Override
public LispObject execute(LispObject[] args) {
LispObject result = Fixnum.ZERO;
final int length = args.length;
for (int i = 0; i < length; i++)
result = result.add(args[i]);
return result;
}
};
// ### 1+
private static final Primitive ONE_PLUS = new pf_one_plus();
private static final class pf_one_plus extends Primitive {
pf_one_plus() {
super(Symbol.ONE_PLUS, "number");
}
@Override
public LispObject execute(LispObject arg) {
return arg.incr();
}
};
// ### -
private static final Primitive SUBTRACT = new pf_subtract();
private static final class pf_subtract extends Primitive {
pf_subtract() {
super(Symbol.MINUS, "minuend &rest subtrahends");
}
@Override
public LispObject execute() {
return error(new WrongNumberOfArgumentsException(this, 1, -1));
}
@Override
public LispObject execute(LispObject arg) {
return arg.negate();
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.subtract(second);
}
@Override
public LispObject execute(LispObject[] args) {
LispObject result = args[0];
for (int i = 1; i < args.length; i++)
result = result.subtract(args[i]);
return result;
}
};
// ### 1-
private static final Primitive ONE_MINUS = new pf_one_minus();
private static final class pf_one_minus extends Primitive {
pf_one_minus() {
super(Symbol.ONE_MINUS, "number");
}
@Override
public LispObject execute(LispObject arg) {
return arg.decr();
}
};
// ### when
private static final SpecialOperator WHEN = new sf_when();
private static final class sf_when extends SpecialOperator {
sf_when() {
super(Symbol.WHEN);
}
@Override
public LispObject execute(LispObject args, Environment env)
{
if (args == NIL)
return error(new WrongNumberOfArgumentsException(this, 1, -1));
final LispThread thread = LispThread.currentThread();
if (eval(args.car(), env, thread) != NIL) {
args = args.cdr();
thread.clearValues();
return progn(args, env, thread);
}
return thread.setValues(NIL);
}
};
// ### unless
private static final SpecialOperator UNLESS = new sf_unless();
private static final class sf_unless extends SpecialOperator {
sf_unless() {
super(Symbol.UNLESS);
}
@Override
public LispObject execute(LispObject args, Environment env)
{
if (args == NIL)
return error(new WrongNumberOfArgumentsException(this, 1, -1));
final LispThread thread = LispThread.currentThread();
if (eval(args.car(), env, thread) == NIL) {
args = args.cdr();
thread.clearValues();
return progn(args, env, thread);
}
return thread.setValues(NIL);
}
};
// ### %stream-output-object object stream => object
private static final Primitive _STREAM_OUTPUT_OBJECT = new pf__stream_output_object();
private static final class pf__stream_output_object extends Primitive {
pf__stream_output_object() {
super("%stream-output-object", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
checkStream(second)._writeString(first.printObject());
return first;
}
};
// ### %output-object object stream => object
private static final Primitive _OUTPUT_OBJECT = new pf__output_object();
private static final class pf__output_object extends Primitive {
pf__output_object() {
super("%output-object", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
final LispObject out;
if (second == T)
out = Symbol.TERMINAL_IO.symbolValue();
else if (second == NIL)
out = Symbol.STANDARD_OUTPUT.symbolValue();
else
out = second;
String output = first.printObject();
checkStream(out)._writeString(output);
return first;
}
};
// ### %write-to-string object => string
private static final Primitive _WRITE_TO_STRING = new pf__write_to_string();
private static final class pf__write_to_string extends Primitive {
pf__write_to_string() {
super("%write-to-string", PACKAGE_SYS, false);
}
@Override
public LispObject execute(LispObject arg) {
return new SimpleString(arg.printObject());
}
};
// ### %stream-terpri output-stream => nil
private static final Primitive _STREAM_TERPRI = new pf__stream_terpri();
private static final class pf__stream_terpri extends Primitive {
pf__stream_terpri() {
super("%stream-terpri", PACKAGE_SYS, true, "output-stream");
}
@Override
public LispObject execute(LispObject arg) {
checkStream(arg)._writeChar('\n');
return NIL;
}
};
// ### %terpri output-stream => nil
private static final Primitive _TERPRI = new pf__terpri();
private static final class pf__terpri extends Primitive {
pf__terpri() {
super("%terpri", PACKAGE_SYS, false, "output-stream");
}
@Override
public LispObject execute(LispObject arg) {
if (arg == T)
arg = Symbol.TERMINAL_IO.symbolValue();
else if (arg == NIL)
arg = Symbol.STANDARD_OUTPUT.symbolValue();
final Stream stream;
stream = checkStream(arg);
return stream.terpri();
}
};
// ### %fresh-line
// %fresh-line &optional output-stream => generalized-boolean
private static final Primitive _FRESH_LINE = new pf__fresh_line();
private static final class pf__fresh_line extends Primitive {
pf__fresh_line() {
super("%fresh-line", PACKAGE_SYS, false, "output-stream");
}
@Override
public LispObject execute(LispObject arg) {
if (arg == T)
arg = Symbol.TERMINAL_IO.symbolValue();
else if (arg == NIL)
arg = Symbol.STANDARD_OUTPUT.symbolValue();
final Stream stream;
stream = checkStream(arg);
return stream.freshLine();
}
};
// ### boundp
// Determines only whether a symbol has a value in the global environment;
// any lexical bindings are ignored.
private static final Primitive BOUNDP = new pf_boundp();
private static final class pf_boundp extends Primitive {
pf_boundp() {
super(Symbol.BOUNDP, "symbol");
}
@Override
public LispObject execute(LispObject arg) {
final Symbol symbol;
symbol = checkSymbol(arg);
// PROGV: "If too few values are supplied, the remaining symbols
// are bound and then made to have no value." So BOUNDP must
// explicitly check for a binding with no value.
SpecialBinding binding =
LispThread.currentThread().getSpecialBinding(symbol);
if (binding != null)
return binding.value != null ? T : NIL;
// No binding.
return symbol.getSymbolValue() != null ? T : NIL;
}
};
// ### fboundp
private static final Primitive FBOUNDP = new pf_fboundp();
private static final class pf_fboundp extends Primitive {
pf_fboundp() {
super(Symbol.FBOUNDP, "name");
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof Symbol)
return arg.getSymbolFunction() != null ? T : NIL;
if (isValidSetfFunctionName(arg)) {
LispObject f = get(arg.cadr(), Symbol.SETF_FUNCTION, null);
return f != null ? T : NIL;
}
return type_error(arg, FUNCTION_NAME);
}
};
// ### fmakunbound name => name
private static final Primitive FMAKUNBOUND = new pf_fmakunbound();
private static final class pf_fmakunbound extends Primitive {
pf_fmakunbound() {
super(Symbol.FMAKUNBOUND, "name");
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof Symbol) {
checkSymbol(arg).setSymbolFunction(null);
return arg;
}
if (isValidSetfFunctionName(arg)) {
remprop((Symbol)arg.cadr(), Symbol.SETF_FUNCTION);
return arg;
}
return type_error(arg, FUNCTION_NAME);
}
};
// ### setf-function-name-p
private static final Primitive SETF_FUNCTION_NAME_P = new pf_setf_function_name_p();
private static final class pf_setf_function_name_p extends Primitive {
pf_setf_function_name_p() {
super("setf-function-name-p", PACKAGE_SYS, true, "thing");
}
@Override
public LispObject execute(LispObject arg) {
return isValidSetfFunctionName(arg) ? T : NIL;
}
};
// ### remprop
private static final Primitive REMPROP = new pf_remprop();
private static final class pf_remprop extends Primitive {
pf_remprop() {
super(Symbol.REMPROP, "symbol indicator");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return remprop(checkSymbol(first), second);
}
};
// ### append
public static final Primitive APPEND = new pf_append();
private static final class pf_append extends Primitive {
pf_append() {
super(Symbol.APPEND, "&rest lists");
}
@Override
public LispObject execute() {
return NIL;
}
@Override
public LispObject execute(LispObject arg) {
return arg;
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
if (first == NIL)
return second;
// APPEND is required to copy its first argument.
Cons result = new Cons(first.car());
Cons splice = result;
first = first.cdr();
while (first != NIL) {
Cons temp = new Cons(first.car());
splice.cdr = temp;
splice = temp;
first = first.cdr();
}
splice.cdr = second;
return result;
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
if (first == NIL)
return execute(second, third);
Cons result = new Cons(first.car());
Cons splice = result;
first = first.cdr();
while (first != NIL) {
Cons temp = new Cons(first.car());
splice.cdr = temp;
splice = temp;
first = first.cdr();
}
while (second != NIL) {
Cons temp = new Cons(second.car());
splice.cdr = temp;
splice = temp;
second = second.cdr();
}
splice.cdr = third;
return result;
}
@Override
public LispObject execute(LispObject[] args) {
Cons result = null;
Cons splice = null;
final int limit = args.length - 1;
int i;
for (i = 0; i < limit; i++) {
LispObject top = args[i];
if (top == NIL)
continue;
result = new Cons(top.car());
splice = result;
top = top.cdr();
while (top != NIL) {
Cons temp = new Cons(top.car());
splice.cdr = temp;
splice = temp;
top = top.cdr();
}
break;
}
if (result == null)
return args[i];
for (++i; i < limit; i++) {
LispObject top = args[i];
while (top != NIL) {
Cons temp = new Cons(top.car());
splice.cdr = temp;
splice = temp;
top = top.cdr();
}
}
splice.cdr = args[i];
return result;
}
};
// ### nconc
private static final Primitive NCONC = new pf_nconc();
private static final class pf_nconc extends Primitive {
pf_nconc() {
super(Symbol.NCONC, "&rest lists");
}
@Override
public LispObject execute() {
return NIL;
}
@Override
public LispObject execute(LispObject arg) {
return arg;
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
if (first == NIL)
return second;
if (first instanceof Cons) {
LispObject result = first;
Cons splice = null;
while (first instanceof Cons) {
splice = (Cons) first;
first = splice.cdr;
}
splice.cdr = second;
return result;
}
return type_error(first, Symbol.LIST);
}
@Override
public LispObject execute(LispObject[] array) {
LispObject result = null;
Cons splice = null;
final int limit = array.length - 1;
int i;
for (i = 0; i < limit; i++) {
LispObject list = array[i];
if (list == NIL)
continue;
if (list instanceof Cons) {
if (splice != null) {
splice.cdr = list;
splice = (Cons) list;
}
while (list instanceof Cons) {
if (result == null) {
result = list;
splice = (Cons) result;
} else
splice = (Cons) list;
list = splice.cdr;
}
} else
type_error(list, Symbol.LIST);
}
if (result == null)
return array[i];
splice.cdr = array[i];
return result;
}
};
// ### =
// Numeric equality.
private static final Primitive EQUALS = new pf_equals();
private static final class pf_equals extends Primitive {
pf_equals() {
super(Symbol.EQUALS, "&rest numbers");
}
@Override
public LispObject execute() {
return error(new WrongNumberOfArgumentsException(this, 1, -1));
}
@Override
public LispObject execute(LispObject arg) {
return T;
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.isEqualTo(second) ? T : NIL;
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
if (first.isEqualTo(second) && second.isEqualTo(third))
return T;
else
return NIL;
}
@Override
public LispObject execute(LispObject[] array) {
final int length = array.length;
final LispObject obj = array[0];
for (int i = 1; i < length; i++) {
if (array[i].isNotEqualTo(obj))
return NIL;
}
return T;
}
};
// ### /=
// Returns true if no two numbers are the same; otherwise returns false.
private static final Primitive NOT_EQUALS = new pf_not_equals();
private static final class pf_not_equals extends Primitive {
pf_not_equals() {
super(Symbol.NOT_EQUALS, "&rest numbers");
}
@Override
public LispObject execute() {
return error(new WrongNumberOfArgumentsException(this, 1, -1));
}
@Override
public LispObject execute(LispObject arg) {
return T;
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.isNotEqualTo(second) ? T : NIL;
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
if (first.isEqualTo(second))
return NIL;
if (first.isEqualTo(third))
return NIL;
if (second.isEqualTo(third))
return NIL;
return T;
}
@Override
public LispObject execute(LispObject[] array) {
final int length = array.length;
for (int i = 0; i < length; i++) {
final LispObject obj = array[i];
for (int j = i+1; j < length; j++) {
if (array[j].isEqualTo(obj))
return NIL;
}
}
return T;
}
};
// ### <
// Numeric comparison.
private static final Primitive LT = new pf_lt();
private static final class pf_lt extends Primitive {
pf_lt() {
super(Symbol.LT, "&rest numbers");
}
@Override
public LispObject execute() {
return error(new WrongNumberOfArgumentsException(this, 1, -1));
}
@Override
public LispObject execute(LispObject arg) {
return T;
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.isLessThan(second) ? T : NIL;
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
if (first.isLessThan(second) && second.isLessThan(third))
return T;
else
return NIL;
}
@Override
public LispObject execute(LispObject[] array) {
final int length = array.length;
for (int i = 1; i < length; i++) {
if (array[i].isLessThanOrEqualTo(array[i-1]))
return NIL;
}
return T;
}
};
// ### <=
private static final Primitive LE = new pf_le();
private static final class pf_le extends Primitive {
pf_le() {
super(Symbol.LE, "&rest numbers");
}
@Override
public LispObject execute() {
return error(new WrongNumberOfArgumentsException(this, 1, -1));
}
@Override
public LispObject execute(LispObject arg) {
return T;
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.isLessThanOrEqualTo(second) ? T : NIL;
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
if (first.isLessThanOrEqualTo(second) && second.isLessThanOrEqualTo(third))
return T;
else
return NIL;
}
@Override
public LispObject execute(LispObject[] array) {
final int length = array.length;
for (int i = 1; i < length; i++) {
if (array[i].isLessThan(array[i-1]))
return NIL;
}
return T;
}
};
// ### >
private static final Primitive GT = new pf_gt();
private static final class pf_gt extends Primitive {
pf_gt() {
super(Symbol.GT, "&rest numbers");
}
@Override
public LispObject execute() {
return error(new WrongNumberOfArgumentsException(this, 1, -1));
}
@Override
public LispObject execute(LispObject arg) {
return T;
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.isGreaterThan(second) ? T : NIL;
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
if (first.isGreaterThan(second) && second.isGreaterThan(third))
return T;
else
return NIL;
}
@Override
public LispObject execute(LispObject[] array) {
final int length = array.length;
for (int i = 1; i < length; i++) {
if (array[i].isGreaterThanOrEqualTo(array[i-1]))
return NIL;
}
return T;
}
};
// ### >=
private static final Primitive GE = new pf_ge();
private static final class pf_ge extends Primitive {
pf_ge() {
super(Symbol.GE, "&rest numbers");
}
@Override
public LispObject execute() {
return error(new WrongNumberOfArgumentsException(this, 1, -1));
}
@Override
public LispObject execute(LispObject arg) {
return T;
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.isGreaterThanOrEqualTo(second) ? T : NIL;
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
if (first.isGreaterThanOrEqualTo(second) && second.isGreaterThanOrEqualTo(third))
return T;
else
return NIL;
}
@Override
public LispObject execute(LispObject[] array) {
final int length = array.length;
for (int i = 1; i < length; i++) {
if (array[i].isGreaterThan(array[i-1]))
return NIL;
}
return T;
}
};
// ### nth n list => object
private static final Primitive NTH = new pf_nth();
private static final class pf_nth extends Primitive {
pf_nth() {
super(Symbol.NTH, "n list");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return second.NTH(first);
}
};
// ### %set-nth n list new-object => new-object
private static final Primitive _SET_NTH = new pf__set_nth();
private static final class pf__set_nth extends Primitive {
pf__set_nth() {
super("%set-nth", PACKAGE_SYS, false);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
int index = Fixnum.getValue(first);
if (index < 0)
error(new TypeError("(SETF NTH): invalid index " + index + "."));
int i = 0;
while (true) {
if (i == index) {
second.setCar(third);
return third;
}
second = second.cdr();
if (second == NIL) {
return error(new LispError("(SETF NTH): the index " +
index + "is too large."));
}
++i;
}
}
};
// ### nthcdr
private static final Primitive NTHCDR = new pf_nthcdr();
private static final class pf_nthcdr extends Primitive {
pf_nthcdr() {
super(Symbol.NTHCDR, "n list");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
final int index = Fixnum.getValue(first);
if (index < 0)
return type_error(first,
list(Symbol.INTEGER, Fixnum.ZERO));
for (int i = 0; i < index; i++) {
second = second.cdr();
if (second == NIL)
return NIL;
}
return second;
}
};
/** Stub to be replaced later when signal.lisp has been loaded. */
// ### error
private static final Primitive ERROR = new pf_error();
private static final class pf_error extends Primitive {
pf_error() {
super(Symbol.ERROR, "datum &rest arguments");
}
@Override
@SuppressWarnings("CallToThreadDumpStack")
public LispObject execute(LispObject[] args) {
Error e = new IntegrityError();
e.printStackTrace();
System.out.println("ERROR placeholder called with arguments:");
if (args.length == 1 && args[0] instanceof Condition) {
System.out.println(args[0].princToString());
System.out.println(((Condition)args[0]).getConditionReport());
} else
for (LispObject a : args)
System.out.println(a.princToString());
throw e;
}
};
/** Stub replaced when compiler-pass2.lisp has been loaded */
// ### autocompile
private static final Primitive AUTOCOMPILE = new pf_autocompile();
private static final class pf_autocompile extends Primitive {
pf_autocompile() {
super(Symbol.AUTOCOMPILE, "function");
}
@Override
public LispObject execute(LispObject function) {
return NIL;
}
};
// ### signal
/** Placeholder function, to be replaced by the function
* defined in signal.lisp
*
* Calling this function is an error: we're not set up for
* signalling yet.
*/
private static final Primitive SIGNAL = new pf_signal();
private static final class pf_signal extends Primitive {
pf_signal() {
super(Symbol.SIGNAL, "datum &rest arguments");
}
@Override
public LispObject execute(LispObject[] args) {
if (args.length < 1)
return error(new WrongNumberOfArgumentsException(this, 1, -1));
if (args[0] instanceof Condition)
return error((Condition)args[0]);
return error(new SimpleCondition());
}
};
// ### undefined-function-called
// Redefined in restart.lisp.
private static final Primitive UNDEFINED_FUNCTION_CALLED = new pf_undefined_function_called();
private static final class pf_undefined_function_called extends Primitive {
pf_undefined_function_called() {
super(Symbol.UNDEFINED_FUNCTION_CALLED, "name arguments");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return error(new UndefinedFunction(first));
}
};
// ### %format
private static final Primitive _FORMAT = new pf__format();
private static final class pf__format extends Primitive {
pf__format() {
super("%format", PACKAGE_SYS, false,
"destination control-string &rest args");
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
LispObject destination = first;
// Copy remaining arguments.
LispObject[] _args = new LispObject[2];
_args[0] = second;
_args[1] = third;
String s = _format(_args);
return outputFormattedString(s, destination);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third, LispObject fourth)
{
LispObject destination = first;
// Copy remaining arguments.
LispObject[] _args = new LispObject[3];
_args[0] = second;
_args[1] = third;
_args[2] = fourth;
String s = _format(_args);
return outputFormattedString(s, destination);
}
@Override
public LispObject execute(LispObject[] args) {
if (args.length < 2)
return error(new WrongNumberOfArgumentsException(this, 2, -1));
LispObject destination = args[0];
// Copy remaining arguments.
LispObject[] _args = new LispObject[args.length - 1];
for (int i = 0; i < _args.length; i++)
_args[i] = args[i+1];
String s = _format(_args);
return outputFormattedString(s, destination);
}
private final String _format(LispObject[] args)
{
LispObject formatControl = args[0];
LispObject formatArguments = NIL;
for (int i = 1; i < args.length; i++)
formatArguments = new Cons(args[i], formatArguments);
formatArguments = formatArguments.nreverse();
return format(formatControl, formatArguments);
}
private final LispObject outputFormattedString(String s,
LispObject destination)
{
if (destination == T) {
checkCharacterOutputStream(Symbol.STANDARD_OUTPUT.symbolValue())._writeString(s);
return NIL;
}
if (destination == NIL)
return new SimpleString(s);
if (destination instanceof TwoWayStream) {
Stream out = ((TwoWayStream)destination).getOutputStream();
if (out instanceof Stream) {
(out)._writeString(s);
return NIL;
}
error(new TypeError("The value " +
destination.princToString() +
" is not a character output stream."));
}
if (destination instanceof Stream) {
((Stream)destination)._writeString(s);
return NIL;
}
return NIL;
}
};
static void checkRedefinition(LispObject arg)
{
final LispThread thread = LispThread.currentThread();
if (_WARN_ON_REDEFINITION_.symbolValue(thread) != NIL) {
if (arg instanceof Symbol) {
LispObject oldDefinition = arg.getSymbolFunction();
if (oldDefinition != null
&& !(oldDefinition instanceof Autoload)) {
LispObject oldSource =
Extensions.SOURCE_PATHNAME.execute(arg);
LispObject currentSource = _SOURCE_.symbolValue(thread);
if (currentSource == NIL)
currentSource = Keyword.TOP_LEVEL;
if (oldSource != NIL) {
if (currentSource.equal(oldSource))
return; // OK
}
if (currentSource == Keyword.TOP_LEVEL) {
Symbol.STYLE_WARN.execute(new SimpleString("redefining ~S at top level"),
arg);
} else {
SpecialBindingsMark mark = thread.markSpecialBindings();
thread.bindSpecial(Symbol._PACKAGE_, PACKAGE_CL);
try {
Symbol.STYLE_WARN.execute(new SimpleString("redefining ~S in ~S"),
arg, currentSource);
}
finally {
thread.resetSpecialBindings(mark);
}
}
}
}
}
}
// ### %defun name definition => name
private static final Primitive _DEFUN = new pf__defun();
private static final class pf__defun extends Primitive {
pf__defun() {
super("%defun", PACKAGE_SYS, true, "name definition");
}
@Override
public LispObject execute(LispObject name, LispObject definition)
{
if (name instanceof Symbol) {
Symbol symbol = (Symbol) name;
if (symbol.getSymbolFunction() instanceof SpecialOperator) {
return program_error(symbol.getName() + " is a special operator and may not be redefined.");
}
} else if (!isValidSetfFunctionName(name))
return type_error(name, FUNCTION_NAME);
if (definition instanceof Function) {
Symbol.FSET.execute(name, definition, NIL,
((Function)definition).getLambdaList());
return name;
}
return type_error(definition, Symbol.FUNCTION);
}
};
// ### fdefinition-block-name
private static final Primitive FDEFINITION_BLOCK_NAME = new pf_fdefinition_block_name();
private static final class pf_fdefinition_block_name extends Primitive {
pf_fdefinition_block_name() {
super("fdefinition-block-name", PACKAGE_SYS, true, "function-name");
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof Symbol)
return arg;
if (isValidSetfFunctionName(arg))
return arg.cadr();
return type_error(arg, FUNCTION_NAME);
}
};
// ### macro-function
private static final Primitive MACRO_FUNCTION = new pf_macro_function();
private static final class pf_macro_function extends Primitive {
pf_macro_function() {
super(Symbol.MACRO_FUNCTION, "symbol &optional environment");
}
@Override
public LispObject execute(LispObject arg) {
LispObject obj = arg.getSymbolFunction();
if (obj instanceof AutoloadMacro) {
((AutoloadMacro)obj).load();
obj = arg.getSymbolFunction();
}
if (obj instanceof MacroObject)
return ((MacroObject)obj).expander;
if (obj instanceof SpecialOperator) {
obj = get(arg, Symbol.MACROEXPAND_MACRO, NIL);
if (obj instanceof AutoloadMacro) {
((AutoloadMacro)obj).load();
obj = get(arg, Symbol.MACROEXPAND_MACRO, NIL);
}
if (obj instanceof MacroObject)
return ((MacroObject)obj).expander;
}
return NIL;
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
LispObject obj;
if (second != NIL) {
Environment env = checkEnvironment(second);
obj = env.lookupFunction(first);
} else
obj = first.getSymbolFunction();
if (obj instanceof AutoloadMacro) {
((AutoloadMacro)obj).load();
obj = first.getSymbolFunction();
}
if (obj instanceof MacroObject)
return ((MacroObject)obj).expander;
if (obj instanceof SpecialOperator) {
obj = get(first, Symbol.MACROEXPAND_MACRO, NIL);
if (obj instanceof AutoloadMacro) {
((AutoloadMacro)obj).load();
obj = get(first, Symbol.MACROEXPAND_MACRO, NIL);
}
if (obj instanceof MacroObject)
return ((MacroObject)obj).expander;
}
return NIL;
}
};
// ### defmacro
private static final SpecialOperator DEFMACRO = new sf_defmacro();
private static final class sf_defmacro extends SpecialOperator {
sf_defmacro() {
super(Symbol.DEFMACRO);
}
@Override
public LispObject execute(LispObject args, Environment env)
{
Symbol symbol = checkSymbol(args.car());
LispObject expander = MAKE_MACRO_EXPANDER.execute(args);
Closure expansionFunction = new Closure(expander, env);
MacroObject macroObject =
new MacroObject(symbol, expansionFunction);
if (symbol.getSymbolFunction() instanceof SpecialOperator)
put(symbol, Symbol.MACROEXPAND_MACRO, macroObject);
else
symbol.setSymbolFunction(macroObject);
macroObject.setLambdaList(args.cadr());
LispThread.currentThread()._values = null;
return symbol;
}
};
// ### make-macro
private static final Primitive MAKE_MACRO = new pf_make_macro();
private static final class pf_make_macro extends Primitive {
pf_make_macro() {
super("make-macro", PACKAGE_SYS, true, "name expansion-function");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return new MacroObject(first, second);
}
};
// ### macro-function-p
private static final Primitive MACRO_FUNCTION_P = new pf_macro_function_p();
private static final class pf_macro_function_p extends Primitive {
pf_macro_function_p() {
super("macro-function-p", PACKAGE_SYS, true, "value");
}
@Override
public LispObject execute(LispObject arg) {
return (arg instanceof MacroObject) ? T : NIL;
}
};
// ### make-symbol-macro
private static final Primitive MAKE_SYMBOL_MACRO = new pf_make_symbol_macro();
private static final class pf_make_symbol_macro extends Primitive {
pf_make_symbol_macro() {
super("make-symbol-macro", PACKAGE_SYS, true, "expansion");
}
@Override
public LispObject execute(LispObject arg) {
return new SymbolMacro(arg);
}
};
// ### %set-symbol-macro
private static final Primitive SET_SYMBOL_MACRO = new pf_set_symbol_macro();
private static final class pf_set_symbol_macro extends Primitive {
pf_set_symbol_macro() {
super("%set-symbol-macro", PACKAGE_SYS, false, "symbol symbol-macro");
}
@Override
public LispObject execute(LispObject sym, LispObject symbolMacro) {
checkSymbol(sym).setSymbolMacro((SymbolMacro) symbolMacro);
return symbolMacro;
}
};
// ### symbol-macro-p
private static final Primitive SYMBOL_MACRO_P = new pf_symbol_macro_p();
private static final class pf_symbol_macro_p extends Primitive {
pf_symbol_macro_p() {
super("symbol-macro-p", PACKAGE_SYS, true, "value");
}
@Override
public LispObject execute(LispObject arg) {
return (arg instanceof SymbolMacro) ? T : NIL;
}
};
// ### %defparameter
private static final Primitive _DEFPARAMETER = new pf__defparameter();
private static final class pf__defparameter extends Primitive {
pf__defparameter() {
super("%defparameter", PACKAGE_SYS, false);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
final Symbol symbol;
symbol = checkSymbol(first);
if (third instanceof AbstractString)
symbol.setDocumentation(Symbol.VARIABLE, third);
else if (third != NIL)
type_error(third, Symbol.STRING);
symbol.initializeSpecial(second);
return symbol;
}
};
// ### %defvar
private static final Primitive _DEFVAR = new pf__defvar();
private static final class pf__defvar extends Primitive {
pf__defvar() {
super("%defvar", PACKAGE_SYS, false);
}
@Override
public LispObject execute(LispObject arg) {
final Symbol symbol;
symbol = checkSymbol(arg);
symbol.setSpecial(true);
return symbol;
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
final Symbol symbol;
symbol = checkSymbol(first);
symbol.initializeSpecial(second);
return symbol;
}
};
// ### %defconstant name initial-value documentation => name
private static final Primitive _DEFCONSTANT = new pf__defconstant();
private static final class pf__defconstant extends Primitive {
pf__defconstant() {
super("%defconstant", PACKAGE_SYS, false);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
final Symbol symbol;
symbol = checkSymbol(first);
if (third != NIL) {
if (third instanceof AbstractString)
symbol.setDocumentation(Symbol.VARIABLE, third);
else
return type_error(third, Symbol.STRING);
}
symbol.initializeConstant(second);
return symbol;
}
};
// ### cond
private static final SpecialOperator COND = new sf_cond();
private static final class sf_cond extends SpecialOperator {
sf_cond() {
super(Symbol.COND, "&rest clauses");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
final LispThread thread = LispThread.currentThread();
LispObject result = NIL;
while (args != NIL) {
LispObject clause = args.car();
if (! (clause instanceof Cons))
return error(new ProgramError("COND clause is not a non-empty list: "
+ clause.princToString()));
result = eval(clause.car(), env, thread);
thread._values = null;
if (result != NIL) {
LispObject body = clause.cdr();
while (body != NIL) {
result = eval(body.car(), env, thread);
body = ((Cons)body).cdr;
}
return result;
}
args = ((Cons)args).cdr;
}
return result;
}
};
// ### case
private static final SpecialOperator CASE = new sf_case();
private static final class sf_case extends SpecialOperator {
sf_case() {
super(Symbol.CASE, "keyform &body cases");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
final LispThread thread = LispThread.currentThread();
LispObject key = eval(args.car(), env, thread);
args = args.cdr();
while (args != NIL) {
LispObject clause = args.car();
LispObject keys = clause.car();
boolean match = false;
if (keys.listp()) {
while (keys != NIL) {
LispObject candidate = keys.car();
if (key.eql(candidate)) {
match = true;
break;
}
keys = keys.cdr();
}
} else {
LispObject candidate = keys;
if (candidate == T || candidate == Symbol.OTHERWISE)
match = true;
else if (key.eql(candidate))
match = true;
}
if (match) {
return progn(clause.cdr(), env, thread);
}
args = args.cdr();
}
return NIL;
}
};
// ### ecase
private static final SpecialOperator ECASE = new sf_ecase();
private static final class sf_ecase extends SpecialOperator {
sf_ecase() {
super(Symbol.ECASE, "keyform &body cases");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
final LispThread thread = LispThread.currentThread();
LispObject key = eval(args.car(), env, thread);
LispObject clauses = args.cdr();
while (clauses != NIL) {
LispObject clause = clauses.car();
LispObject keys = clause.car();
boolean match = false;
if (keys.listp()) {
while (keys != NIL) {
LispObject candidate = keys.car();
if (key.eql(candidate)) {
match = true;
break;
}
keys = keys.cdr();
}
} else {
LispObject candidate = keys;
if (key.eql(candidate))
match = true;
}
if (match) {
return progn(clause.cdr(), env, thread);
}
clauses = clauses.cdr();
}
LispObject expectedType = NIL;
clauses = args.cdr();
while (clauses != NIL) {
LispObject clause = clauses.car();
LispObject keys = clause.car();
if (keys.listp()) {
while (keys != NIL) {
expectedType = expectedType.push(keys.car());
keys = keys.cdr();
}
} else
expectedType = expectedType.push(keys);
clauses = clauses.cdr();
}
expectedType = expectedType.nreverse();
expectedType = expectedType.push(Symbol.MEMBER);
return type_error(key, expectedType);
}
};
// ### upgraded-array-element-type typespec &optional environment
// => upgraded-typespec
private static final Primitive UPGRADED_ARRAY_ELEMENT_TYPE = new pf_upgraded_array_element_type();
private static final class pf_upgraded_array_element_type extends Primitive {
pf_upgraded_array_element_type() {
super(Symbol.UPGRADED_ARRAY_ELEMENT_TYPE,
"typespec &optional environment");
}
@Override
public LispObject execute(LispObject arg) {
return getUpgradedArrayElementType(arg);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
// Ignore environment.
return getUpgradedArrayElementType(first);
}
};
// ### array-rank array => rank
private static final Primitive ARRAY_RANK = new pf_array_rank();
private static final class pf_array_rank extends Primitive {
pf_array_rank() {
super(Symbol.ARRAY_RANK, "array");
}
@Override
public LispObject execute(LispObject arg) {
return Fixnum.getInstance(checkArray(arg).getRank());
}
};
// ### array-dimensions array => dimensions
// Returns a list of integers. Fill pointer (if any) is ignored.
private static final Primitive ARRAY_DIMENSIONS = new pf_array_dimensions();
private static final class pf_array_dimensions extends Primitive {
pf_array_dimensions() {
super(Symbol.ARRAY_DIMENSIONS, "array");
}
@Override
public LispObject execute(LispObject arg) {
return checkArray(arg).getDimensions();
}
};
// ### array-dimension array axis-number => dimension
private static final Primitive ARRAY_DIMENSION = new pf_array_dimension();
private static final class pf_array_dimension extends Primitive {
pf_array_dimension() {
super(Symbol.ARRAY_DIMENSION, "array axis-number");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
final AbstractArray array = checkArray(first);
return Fixnum.getInstance(array.getDimension(Fixnum.getValue(second)));
}
};
// ### array-total-size array => size
private static final Primitive ARRAY_TOTAL_SIZE = new pf_array_total_size();
private static final class pf_array_total_size extends Primitive {
pf_array_total_size() {
super(Symbol.ARRAY_TOTAL_SIZE, "array");
}
@Override
public LispObject execute(LispObject arg) {
return Fixnum.getInstance(checkArray(arg).getTotalSize());
}
};
// ### array-element-type
// array-element-type array => typespec
private static final Primitive ARRAY_ELEMENT_TYPE = new pf_array_element_type();
private static final class pf_array_element_type extends Primitive {
pf_array_element_type() {
super(Symbol.ARRAY_ELEMENT_TYPE, "array");
}
@Override
public LispObject execute(LispObject arg) {
return checkArray(arg).getElementType();
}
};
// ### adjustable-array-p
private static final Primitive ADJUSTABLE_ARRAY_P = new pf_adjustable_array_p();
private static final class pf_adjustable_array_p extends Primitive {
pf_adjustable_array_p() {
super(Symbol.ADJUSTABLE_ARRAY_P, "array");
}
@Override
public LispObject execute(LispObject arg) {
return checkArray(arg).isAdjustable() ? T : NIL;
}
};
// ### array-displacement array => displaced-to, displaced-index-offset
private static final Primitive ARRAY_DISPLACEMENT = new pf_array_displacement();
private static final class pf_array_displacement extends Primitive {
pf_array_displacement() {
super(Symbol.ARRAY_DISPLACEMENT, "array");
}
@Override
public LispObject execute(LispObject arg) {
return checkArray(arg).arrayDisplacement();
}
};
// ### array-in-bounds-p array &rest subscripts => generalized-boolean
private static final Primitive ARRAY_IN_BOUNDS_P = new pf_array_in_bounds_p();
private static final class pf_array_in_bounds_p extends Primitive {
pf_array_in_bounds_p() {
super(Symbol.ARRAY_IN_BOUNDS_P, "array &rest subscripts");
}
@Override
public LispObject execute(LispObject[] args) {
if (args.length < 1)
return error(new WrongNumberOfArgumentsException(this, 1, -1));
final AbstractArray array;
LispObject r = args[0];
array = checkArray(r);
int rank = array.getRank();
if (rank != args.length - 1) {
StringBuilder sb =
new StringBuilder("ARRAY-IN-BOUNDS-P: ");
sb.append("wrong number of subscripts (");
sb.append(args.length - 1);
sb.append(") for array of rank ");
sb.append(rank);
sb.append(".");
program_error(sb.toString());
}
for (int i = 0; i < rank; i++) {
LispObject arg = args[i+1];
if (arg instanceof Fixnum) {
int subscript = ((Fixnum)arg).value;
if (subscript < 0 || subscript >= array.getDimension(i))
return NIL;
} else if (arg instanceof Bignum)
return NIL;
else
type_error(arg, Symbol.INTEGER);
}
return T;
}
};
// ### %array-row-major-index array subscripts => index
private static final Primitive _ARRAY_ROW_MAJOR_INDEX = new pf__array_row_major_index();
private static final class pf__array_row_major_index extends Primitive {
pf__array_row_major_index() {
super("%array-row-major-index", PACKAGE_SYS, false);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
final AbstractArray array;
array = checkArray(first);
LispObject[] subscripts = second.copyToArray();
return number(array.getRowMajorIndex(subscripts));
}
};
// ### aref array &rest subscripts => element
private static final Primitive AREF = new pf_aref();
private static final class pf_aref extends Primitive {
pf_aref() {
super(Symbol.AREF, "array &rest subscripts");
}
@Override
public LispObject execute() {
return error(new WrongNumberOfArgumentsException(this, 1, -1));
}
@Override
public LispObject execute(LispObject arg) {
final AbstractArray array;
array = checkArray( arg);
if (array.getRank() == 0)
return array.AREF(0);
StringBuilder sb =
new StringBuilder("Wrong number of subscripts (0) for array of rank ");
sb.append(array.getRank());
sb.append('.');
return program_error(sb.toString());
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.AREF(second);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
return checkArray(first).get(new int[] {Fixnum.getValue(second),Fixnum.getValue(third)} );
}
@Override
public LispObject execute(LispObject[] args) {
final AbstractArray array = checkArray(args[0]);
final int[] subs = new int[args.length - 1];
for (int i = subs.length; i-- > 0;) {
subs[i] = Fixnum.getValue(args[i+1]);
}
return array.get(subs);
}
};
// ### aset array subscripts new-element => new-element
private static final Primitive ASET = new pf_aset();
private static final class pf_aset extends Primitive {
pf_aset() {
super("aset", PACKAGE_SYS, true,
"array subscripts new-element");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
// Rank zero array.
final ZeroRankArray array;
if (first instanceof ZeroRankArray) {
array = (ZeroRankArray) first;
} else {
return error(new TypeError("The value " +
first.princToString() +
" is not an array of rank 0."));
}
array.aset(0, second);
return second;
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
first.aset(second, third);
return third;
}
@Override
public LispObject execute(LispObject[] args) {
final AbstractArray array = checkArray(args[0]);
final int nsubs = args.length - 2;
final int[] subs = new int[nsubs];
for (int i = nsubs; i-- > 0;)
subs[i] = Fixnum.getValue(args[i+1]);
final LispObject newValue = args[args.length - 1];
array.set(subs, newValue);
return newValue;
}
};
// ### row-major-aref array index => element
private static final Primitive ROW_MAJOR_AREF = new pf_row_major_aref();
private static final class pf_row_major_aref extends Primitive {
pf_row_major_aref() {
super(Symbol.ROW_MAJOR_AREF, "array index");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return checkArray(first).AREF(Fixnum.getValue(second));
}
};
// ### vector
private static final Primitive VECTOR = new pf_vector();
private static final class pf_vector extends Primitive {
pf_vector() {
super(Symbol.VECTOR, "&rest objects");
}
@Override
public LispObject execute(LispObject[] args) {
return new SimpleVector(args);
}
};
// ### fill-pointer
private static final Primitive FILL_POINTER = new pf_fill_pointer();
private static final class pf_fill_pointer extends Primitive {
pf_fill_pointer() {
super(Symbol.FILL_POINTER, "vector");
}
@Override
public LispObject execute(LispObject arg)
{
if (arg instanceof AbstractArray) {
AbstractArray aa = (AbstractArray)arg;
if (aa.hasFillPointer())
return Fixnum.getInstance(aa.getFillPointer());
}
return type_error(arg, list(Symbol.AND, Symbol.VECTOR,
list(Symbol.SATISFIES,
Symbol.ARRAY_HAS_FILL_POINTER_P)));
}
};
// ### %set-fill-pointer vector new-fill-pointer
private static final Primitive _SET_FILL_POINTER = new pf__set_fill_pointer();
private static final class pf__set_fill_pointer extends Primitive {
pf__set_fill_pointer() {
super("%set-fill-pointer", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
if (first instanceof AbstractVector) {
AbstractVector v = (AbstractVector) first;
if (v.hasFillPointer())
v.setFillPointer(second);
else
v.noFillPointer();
return second;
}
return type_error(first, list(Symbol.AND, Symbol.VECTOR,
list(Symbol.SATISFIES,
Symbol.ARRAY_HAS_FILL_POINTER_P)));
}
};
// ### vector-push new-element vector => index-of-new-element
private static final Primitive VECTOR_PUSH = new pf_vector_push();
private static final class pf_vector_push extends Primitive {
pf_vector_push() {
super(Symbol.VECTOR_PUSH, "new-element vector");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
final AbstractVector v = checkVector(second);
int fillPointer = v.getFillPointer();
if (fillPointer < 0)
v.noFillPointer();
if (fillPointer >= v.capacity())
return NIL;
v.aset(fillPointer, first);
v.setFillPointer(fillPointer + 1);
return Fixnum.getInstance(fillPointer);
}
};
// ### vector-push-extend new-element vector &optional extension
// => index-of-new-element
private static final Primitive VECTOR_PUSH_EXTEND = new pf_vector_push_extend();
private static final class pf_vector_push_extend extends Primitive {
pf_vector_push_extend() {
super(Symbol.VECTOR_PUSH_EXTEND,
"new-element vector &optional extension");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return second.VECTOR_PUSH_EXTEND(first);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
return second.VECTOR_PUSH_EXTEND(first, third);
}
};
// ### vector-pop vector => element
private static final Primitive VECTOR_POP = new pf_vector_pop();
private static final class pf_vector_pop extends Primitive {
pf_vector_pop() {
super(Symbol.VECTOR_POP, "vector");
}
@Override
public LispObject execute(LispObject arg) {
final AbstractVector v = checkVector( arg);
int fillPointer = v.getFillPointer();
if (fillPointer < 0)
v.noFillPointer();
if (fillPointer == 0)
error(new LispError("nothing left to pop"));
int newFillPointer = v.checkIndex(fillPointer - 1);
LispObject element = v.AREF(newFillPointer);
v.setFillPointer(newFillPointer);
return element;
}
};
// ### type-of
private static final Primitive TYPE_OF = new pf_type_of();
private static final class pf_type_of extends Primitive {
pf_type_of() {
super(Symbol.TYPE_OF, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg.typeOf();
}
};
// ### class-of
private static final Primitive CLASS_OF = new pf_class_of();
private static final class pf_class_of extends Primitive {
pf_class_of() {
super(Symbol.CLASS_OF, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg.classOf();
}
};
// ### simple-typep
private static final Primitive SIMPLE_TYPEP = new pf_simple_typep();
private static final class pf_simple_typep extends Primitive {
pf_simple_typep() {
super("simple-typep", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return first.typep(second);
}
};
// ### function-lambda-expression function =>
// lambda-expression, closure-p, name
private static final Primitive FUNCTION_LAMBDA_EXPRESSION = new pf_function_lambda_expression();
private static final class pf_function_lambda_expression extends Primitive {
pf_function_lambda_expression() {
super(Symbol.FUNCTION_LAMBDA_EXPRESSION, "function");
}
@Override
public LispObject execute(LispObject arg) {
final LispObject value1, value2, value3;
if (arg instanceof CompiledClosure) {
value1 = NIL;
value2 = T;
LispObject name = ((CompiledClosure)arg).getLambdaName();
value3 = name != null ? name : NIL;
} else if (arg instanceof Closure) {
Closure closure = (Closure) arg;
LispObject expr = closure.getBody();
expr = new Cons(closure.getLambdaList(), expr);
expr = new Cons(Symbol.LAMBDA, expr);
value1 = expr;
Environment env = closure.getEnvironment();
if (env == null || env.isEmpty())
value2 = NIL;
else
value2 = env; // Return environment as closure-p.
LispObject name = ((Closure)arg).getLambdaName();
value3 = name != null ? name : NIL;
} else if (arg instanceof Function) {
value1 = NIL;
value2 = T;
value3 = ((Function)arg).getLambdaName();
} else if (arg.typep(Symbol.GENERIC_FUNCTION) != NIL) {
value1 = NIL;
value2 = T;
value3 = Symbol.GENERIC_FUNCTION_NAME.execute(arg);
} else if (arg instanceof FuncallableStandardObject) {
return this.execute(((FuncallableStandardObject)arg).function);
} else {
return type_error(arg, Symbol.FUNCTION);
}
return LispThread.currentThread().setValues(value1, value2, value3);
}
};
// ### funcall
// This needs to be public for LispAPI.java.
public static final Primitive FUNCALL = new pf_funcall();
private static final class pf_funcall extends Primitive {
pf_funcall() {
super(Symbol.FUNCALL, "function &rest args");
}
@Override
public LispObject execute() {
return error(new WrongNumberOfArgumentsException(this, 1, -1));
}
@Override
public LispObject execute(LispObject arg) {
return LispThread.currentThread().execute(arg);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return LispThread.currentThread().execute(first, second);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
return LispThread.currentThread().execute(first, second, third);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third, LispObject fourth)
{
return LispThread.currentThread().execute(first, second, third,
fourth);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third, LispObject fourth,
LispObject fifth)
{
return LispThread.currentThread().execute(first, second, third,
fourth, fifth);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third, LispObject fourth,
LispObject fifth, LispObject sixth)
{
return LispThread.currentThread().execute(first, second, third,
fourth, fifth, sixth);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third, LispObject fourth,
LispObject fifth, LispObject sixth,
LispObject seventh)
{
return LispThread.currentThread().execute(first, second, third,
fourth, fifth, sixth,
seventh);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third, LispObject fourth,
LispObject fifth, LispObject sixth,
LispObject seventh, LispObject eigth)
{
return LispThread.currentThread().execute(first, second, third,
fourth, fifth, sixth,
seventh, eigth);
}
@Override
public LispObject execute(LispObject[] args) {
final int length = args.length - 1; // Number of arguments.
if (length == 8) {
return LispThread.currentThread().execute(args[0], args[1],
args[2], args[3],
args[4], args[5],
args[6], args[7],
args[8]);
} else {
LispObject[] newArgs = new LispObject[length];
System.arraycopy(args, 1, newArgs, 0, length);
return LispThread.currentThread().execute(args[0], newArgs);
}
}
};
// ### apply
public static final Primitive APPLY = new pf_apply();
private static final class pf_apply extends Primitive {
pf_apply() {
super(Symbol.APPLY, "function &rest args");
}
@Override
public LispObject execute() {
return error(new WrongNumberOfArgumentsException(this, 2, -1));
}
@Override
public LispObject execute(LispObject arg) {
return error(new WrongNumberOfArgumentsException(this, 2, -1));
}
@Override
public LispObject execute(LispObject fun, LispObject args)
{
final LispThread thread = LispThread.currentThread();
final int length = args.length();
switch (length) {
case 0:
return thread.execute(fun);
case 1:
return thread.execute(fun, ((Cons)args).car);
case 2: {
Cons cons = (Cons) args;
return thread.execute(fun, cons.car, ((Cons)cons.cdr).car);
}
case 3:
return thread.execute(fun, args.car(), args.cadr(),
args.cdr().cdr().car());
default: {
final LispObject[] funArgs = new LispObject[length];
int j = 0;
while (args != NIL) {
funArgs[j++] = args.car();
args = args.cdr();
}
return funcall(fun, funArgs, thread);
}
}
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
if (third.listp()) {
final int numFunArgs = 1 + third.length();
final LispObject[] funArgs = new LispObject[numFunArgs];
funArgs[0] = second;
int j = 1;
while (third != NIL) {
funArgs[j++] = third.car();
third = third.cdr();
}
return funcall(first, funArgs, LispThread.currentThread());
}
return type_error(third, Symbol.LIST);
}
@Override
public LispObject execute(final LispObject[] args) {
final int numArgs = args.length;
LispObject spread = args[numArgs - 1];
if (spread.listp()) {
final int numFunArgs = numArgs - 2 + spread.length();
final LispObject[] funArgs = new LispObject[numFunArgs];
int j = 0;
for (int i = 1; i < numArgs - 1; i++)
funArgs[j++] = args[i];
while (spread != NIL) {
funArgs[j++] = spread.car();
spread = spread.cdr();
}
return funcall(args[0], funArgs, LispThread.currentThread());
}
return type_error(spread, Symbol.LIST);
}
};
// ### mapcar
private static final Primitive MAPCAR = new pf_mapcar();
private static final class pf_mapcar extends Primitive {
pf_mapcar() {
super(Symbol.MAPCAR, "function &rest lists");
}
@Override
public LispObject execute(LispObject fun, LispObject list)
{
final LispThread thread = LispThread.currentThread();
LispObject result = NIL;
Cons splice = null;
while (list != NIL) {
Cons cons;
if (list instanceof Cons)
cons = (Cons) list;
else
return type_error(list, Symbol.LIST);
LispObject obj = thread.execute(fun, cons.car);
if (splice == null) {
splice = new Cons(obj, result);
result = splice;
} else {
Cons c = new Cons(obj);
splice.cdr = c;
splice = c;
}
list = cons.cdr;
}
thread._values = null;
return result;
}
@Override
public LispObject execute(LispObject fun, LispObject list1,
LispObject list2)
{
final LispThread thread = LispThread.currentThread();
LispObject result = NIL;
Cons splice = null;
while (list1 != NIL && list2 != NIL) {
LispObject obj =
thread.execute(fun, list1.car(), list2.car());
if (splice == null) {
splice = new Cons(obj, result);
result = splice;
} else {
Cons cons = new Cons(obj);
splice.cdr = cons;
splice = cons;
}
list1 = list1.cdr();
list2 = list2.cdr();
}
thread._values = null;
return result;
}
@Override
public LispObject execute(final LispObject[] args)
{
final int numArgs = args.length;
if (numArgs < 2)
return error(new WrongNumberOfArgumentsException(this, 2, -1));
int commonLength = -1;
for (int i = 1; i < numArgs; i++) {
if (!args[i].listp())
type_error(args[i], Symbol.LIST);
int len = args[i].length();
if (commonLength < 0)
commonLength = len;
else if (commonLength > len)
commonLength = len;
}
final LispThread thread = LispThread.currentThread();
LispObject[] results = new LispObject[commonLength];
final int numFunArgs = numArgs - 1;
final LispObject[] funArgs = new LispObject[numFunArgs];
for (int i = 0; i < commonLength; i++) {
for (int j = 0; j < numFunArgs; j++)
funArgs[j] = args[j+1].car();
results[i] = funcall(args[0], funArgs, thread);
for (int j = 1; j < numArgs; j++)
args[j] = args[j].cdr();
}
thread._values = null;
LispObject result = NIL;
for (int i = commonLength; i-- > 0;)
result = new Cons(results[i], result);
return result;
}
};
// ### mapc
private static final Primitive MAPC = new pf_mapc();
private static final class pf_mapc extends Primitive {
pf_mapc() {
super(Symbol.MAPC, "function &rest lists");
}
@Override
public LispObject execute(LispObject fun, LispObject list)
{
final LispThread thread = LispThread.currentThread();
LispObject result = list;
while (list != NIL) {
Cons cons;
if (list instanceof Cons)
cons = (Cons) list;
else
return type_error(list, Symbol.LIST);
thread.execute(fun, cons.car);
list = cons.cdr;
}
thread._values = null;
return result;
}
@Override
public LispObject execute(LispObject fun, LispObject list1,
LispObject list2)
{
final LispThread thread = LispThread.currentThread();
LispObject result = list1;
while (list1 != NIL && list2 != NIL) {
thread.execute(fun, list1.car(), list2.car());
list1 = ((Cons)list1).cdr;
list2 = ((Cons)list2).cdr;
}
thread._values = null;
return result;
}
@Override
public LispObject execute(final LispObject[] args)
{
final int numArgs = args.length;
if (numArgs < 2)
return error(new WrongNumberOfArgumentsException(this, 2, -1));
int commonLength = -1;
for (int i = 1; i < numArgs; i++) {
if (!args[i].listp())
type_error(args[i], Symbol.LIST);
int len = args[i].length();
if (commonLength < 0)
commonLength = len;
else if (commonLength > len)
commonLength = len;
}
final LispThread thread = LispThread.currentThread();
LispObject result = args[1];
final int numFunArgs = numArgs - 1;
final LispObject[] funArgs = new LispObject[numFunArgs];
for (int i = 0; i < commonLength; i++) {
for (int j = 0; j < numFunArgs; j++)
funArgs[j] = args[j+1].car();
funcall(args[0], funArgs, thread);
for (int j = 1; j < numArgs; j++)
args[j] = args[j].cdr();
}
thread._values = null;
return result;
}
};
// ### macroexpand
private static final Primitive MACROEXPAND = new pf_macroexpand();
private static final class pf_macroexpand extends Primitive {
pf_macroexpand() {
super(Symbol.MACROEXPAND, "form &optional env");
}
@Override
public LispObject execute(LispObject form) {
return macroexpand(form,
new Environment(),
LispThread.currentThread());
}
@Override
public LispObject execute(LispObject form, LispObject env)
{
return macroexpand(form,
env != NIL ? checkEnvironment(env) : new Environment(),
LispThread.currentThread());
}
};
// ### macroexpand-1
private static final Primitive MACROEXPAND_1 = new pf_macroexpand_1();
private static final class pf_macroexpand_1 extends Primitive {
pf_macroexpand_1() {
super(Symbol.MACROEXPAND_1, "form &optional env");
}
@Override
public LispObject execute(LispObject form) {
return macroexpand_1(form,
new Environment(),
LispThread.currentThread());
}
@Override
public LispObject execute(LispObject form, LispObject env)
{
return macroexpand_1(form,
env != NIL ? checkEnvironment(env) : new Environment(),
LispThread.currentThread());
}
};
// ### gensym
public static final Primitive GENSYM = new pf_gensym();
private static final class pf_gensym extends Primitive {
pf_gensym() {
super(Symbol.GENSYM, "&optional x");
}
@Override
public LispObject execute() {
return gensym("G", LispThread.currentThread());
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof Fixnum) {
int n = ((Fixnum)arg).value;
if (n >= 0) {
StringBuilder sb = new StringBuilder("G");
sb.append(n); // Decimal representation.
return new Symbol(new SimpleString(sb));
}
} else if (arg instanceof Bignum) {
BigInteger n = ((Bignum)arg).value;
if (n.signum() >= 0) {
StringBuilder sb = new StringBuilder("G");
sb.append(n.toString()); // Decimal representation.
return new Symbol(new SimpleString(sb));
}
} else if (arg instanceof AbstractString)
return gensym(arg.getStringValue(), LispThread.currentThread());
return type_error(arg,
list(Symbol.OR,
Symbol.STRING,
Symbol.UNSIGNED_BYTE));
}
};
// ### string
private static final Primitive STRING = new pf_string();
private static final class pf_string extends Primitive {
pf_string() {
super(Symbol.STRING, "x");
}
@Override
public LispObject execute(LispObject arg) {
return arg.STRING();
}
};
// ### intern string &optional package => symbol, status
// STATUS is one of :INHERITED, :EXTERNAL, :INTERNAL or NIL.
// "It is implementation-dependent whether the string that becomes the new
// symbol's name is the given string or a copy of it."
private static final Primitive INTERN = new pf_intern();
private static final class pf_intern extends Primitive {
pf_intern() {
super(Symbol.INTERN, "string &optional package");
}
@Override
public LispObject execute(LispObject arg) {
final SimpleString s;
if (arg instanceof SimpleString)
s = (SimpleString) arg;
else
s = new SimpleString(arg.getStringValue());
final LispThread thread = LispThread.currentThread();
Package pkg = (Package) Symbol._PACKAGE_.symbolValue(thread);
return pkg.intern(s, thread);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
final SimpleString s;
if (first instanceof SimpleString)
s = (SimpleString) first;
else
s = new SimpleString(first.getStringValue());
Package pkg = coerceToPackage(second);
return pkg.intern(s, LispThread.currentThread());
}
};
// ### unintern
// unintern symbol &optional package => generalized-boolean
private static final Primitive UNINTERN = new pf_unintern();
private static final class pf_unintern extends Primitive {
pf_unintern() {
super(Symbol.UNINTERN, "symbol &optional package");
}
@Override
public LispObject execute(LispObject[] args) {
if (args.length == 0 || args.length > 2)
return error(new WrongNumberOfArgumentsException(this, 1, 2));
Symbol symbol = checkSymbol(args[0]);
Package pkg;
if (args.length == 2)
pkg = coerceToPackage(args[1]);
else
pkg = getCurrentPackage();
return pkg.unintern(symbol);
}
};
// ### find-package
private static final Primitive FIND_PACKAGE = new pf_find_package();
private static final class pf_find_package extends Primitive {
pf_find_package() {
super(Symbol.FIND_PACKAGE, "name");
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof Package)
return arg;
if (arg instanceof AbstractString) {
Package pkg =
getCurrentPackage().findPackage(arg.getStringValue());
return pkg != null ? pkg : NIL;
}
if (arg instanceof Symbol) {
Package pkg = getCurrentPackage().findPackage(checkSymbol(arg).getName());
return pkg != null ? pkg : NIL;
}
if (arg instanceof LispCharacter) {
String packageName =
String.valueOf(new char[] {((LispCharacter)arg).getValue()});
Package pkg = getCurrentPackage().findPackage(packageName);
return pkg != null ? pkg : NIL;
}
return NIL;
}
};
// ### %make-package
// %make-package package-name nicknames use => package
private static final Primitive _MAKE_PACKAGE = new pf__make_package();
private static final class pf__make_package extends Primitive {
pf__make_package() {
super("%make-package", PACKAGE_SYS, false);
}
/**
* This invocation is solely used to be able to create
* a package to bind to *FASL-ANONYMOUS-PACKAGE*
*/
@Override
public LispObject execute()
{
return new Package();
}
/**
* This invocation is used by MAKE-PACKAGE to create a package
*/
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
String packageName = javaString(first);
Package currentpkg = getCurrentPackage();
Package pkg = currentpkg.findPackage(packageName);
if (pkg != null)
error(new LispError("Package " + packageName +
" already exists."));
LispObject nicknames = checkList(second);
if (nicknames != NIL) {
LispObject list = nicknames;
while (list != NIL) {
LispObject lispNick = list.car();
String nick = javaString(lispNick);
if (currentpkg.findPackage(nick) != null) {
error(new PackageError("A package named " + nick +
" already exists.", lispNick));
}
list = list.cdr();
}
}
LispObject use = checkList(third);
if (use != NIL) {
LispObject list = use;
while (list != NIL) {
LispObject obj = list.car();
if (obj instanceof Package) {
// OK.
} else {
String s = javaString(obj);
Package p = currentpkg.findPackage(s);
if (p == null) {
error(new LispError(obj.princToString() +
" is not the name of a package."));
return NIL;
}
}
list = list.cdr();
}
}
// Now create the package.
pkg = Packages.createPackage(packageName);
// Add the nicknames.
while (nicknames != NIL) {
String nick = javaString(nicknames.car());
pkg.addNickname(nick);
nicknames = nicknames.cdr();
}
// Create the use list.
while (use != NIL) {
LispObject obj = use.car();
if (obj instanceof Package)
pkg.usePackage((Package)obj);
else {
String s = javaString(obj);
Package p = currentpkg.findPackage(s);
if (p == null) {
error(new LispError(obj.princToString() +
" is not the name of a package."));
return NIL;
}
pkg.usePackage(p);
}
use = use.cdr();
}
return pkg;
}
};
// ### %in-package
private static final Primitive _IN_PACKAGE = new pf__in_package();
private static final class pf__in_package extends Primitive {
pf__in_package() {
super("%in-package", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg) {
final String packageName = javaString(arg);
final Package pkg = getCurrentPackage().findPackage(packageName);
if (pkg == null)
return error(new PackageError("The name " + packageName +
" does not designate any package.", arg));
SpecialBinding binding =
LispThread.currentThread().getSpecialBinding(Symbol._PACKAGE_);
if (binding != null)
binding.value = pkg;
else
// No dynamic binding.
Symbol._PACKAGE_.setSymbolValue(pkg);
return pkg;
}
};
// ### use-package packages-to-use &optional package => t
private static final Primitive USE_PACKAGE = new pf_use_package();
private static final class pf_use_package extends Primitive {
pf_use_package() {
super(Symbol.USE_PACKAGE, "packages-to-use &optional package");
}
@Override
public LispObject execute(LispObject[] args) {
if (args.length < 1 || args.length > 2)
return error(new WrongNumberOfArgumentsException(this, 1, 2));
Package pkg;
if (args.length == 2)
pkg = coerceToPackage(args[1]);
else
pkg = getCurrentPackage();
if (args[0].listp()) {
LispObject list = args[0];
while (list != NIL) {
pkg.usePackage(coerceToPackage(list.car()));
list = list.cdr();
}
} else
pkg.usePackage(coerceToPackage(args[0]));
return T;
}
};
// ### package-symbols
private static final Primitive PACKAGE_SYMBOLS = new pf_package_symbols();
private static final class pf_package_symbols extends Primitive {
pf_package_symbols() {
super("package-symbols", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg) {
return coerceToPackage(arg).getSymbols();
}
};
// ### package-internal-symbols
private static final Primitive PACKAGE_INTERNAL_SYMBOLS = new pf_package_internal_symbols();
private static final class pf_package_internal_symbols extends Primitive {
pf_package_internal_symbols() {
super("package-internal-symbols", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg) {
return coerceToPackage(arg).PACKAGE_INTERNAL_SYMBOLS();
}
};
// ### package-external-symbols
private static final Primitive PACKAGE_EXTERNAL_SYMBOLS = new pf_package_external_symbols();
private static final class pf_package_external_symbols extends Primitive {
pf_package_external_symbols() {
super("package-external-symbols", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg) {
return coerceToPackage(arg).PACKAGE_EXTERNAL_SYMBOLS();
}
};
// ### package-inherited-symbols
private static final Primitive PACKAGE_INHERITED_SYMBOLS = new pf_package_inherited_symbols();
private static final class pf_package_inherited_symbols extends Primitive {
pf_package_inherited_symbols() {
super("package-inherited-symbols", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg) {
return coerceToPackage(arg).PACKAGE_INHERITED_SYMBOLS();
}
};
// ### export symbols &optional package
private static final Primitive EXPORT = new pf_export();
private static final class pf_export extends Primitive {
pf_export() {
super(Symbol.EXPORT, "symbols &optional package");
}
@Override
public LispObject execute(LispObject arg) {
final Package pkg = (Package) Symbol._PACKAGE_.symbolValue();
if (arg instanceof Cons) {
for (LispObject list = arg; list != NIL; list = list.cdr())
pkg.export(checkSymbol(list.car()));
} else
pkg.export(checkSymbol(arg));
return T;
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
if (first instanceof Cons) {
Package pkg = coerceToPackage(second);
for (LispObject list = first; list != NIL; list = list.cdr())
pkg.export(checkSymbol(list.car()));
} else
coerceToPackage(second).export(checkSymbol(first));
return T;
}
};
// ### find-symbol string &optional package => symbol, status
private static final Primitive FIND_SYMBOL = new pf_find_symbol();
private static final class pf_find_symbol extends Primitive {
pf_find_symbol() {
super(Symbol.FIND_SYMBOL, "string &optional package");
}
@Override
public LispObject execute(LispObject arg) {
return getCurrentPackage()
.findSymbol(checkString(arg).getStringValue());
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return coerceToPackage(second)
.findSymbol(checkString(first).getStringValue());
}
};
// ### fset name function &optional source-position arglist documentation
// => function
private static final Primitive FSET = new pf_fset();
private static final class pf_fset extends Primitive {
pf_fset() {
super("fset", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return execute(first, second, NIL, NIL, NIL);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
return execute(first, second, third, NIL, NIL);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third, LispObject fourth)
{
return execute(first, second, third, fourth, NIL);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third, LispObject fourth,
LispObject fifth)
{
if (first instanceof Symbol) {
checkRedefinition(first);
Symbol symbol = checkSymbol(first);
symbol.setSymbolFunction(second);
final LispThread thread = LispThread.currentThread();
LispObject sourcePathname = _SOURCE_.symbolValue(thread);
LispObject sourcePosition = third;
if (sourcePathname != NIL)
sourcePosition = _SOURCE_POSITION_.symbolValue(thread);
if (sourcePathname == NIL)
sourcePathname = Keyword.TOP_LEVEL;
if (sourcePathname != Keyword.TOP_LEVEL)
put(symbol, Symbol._SOURCE, new Cons(sourcePathname, third));
else
put(symbol, Symbol._SOURCE, sourcePathname);
} else if (isValidSetfFunctionName(first)) {
// SETF function
checkRedefinition(first);
Symbol symbol = checkSymbol(first.cadr());
put(symbol, Symbol.SETF_FUNCTION, second);
} else
return type_error(first, FUNCTION_NAME);
if (second instanceof Operator) {
Operator op = (Operator) second;
op.setLambdaName(first);
if (fourth != NIL)
op.setLambdaList(fourth);
if (fifth != NIL)
op.setDocumentation(Symbol.FUNCTION, fifth);
}
return second;
}
};
// ### %set-symbol-plist
private static final Primitive _SET_SYMBOL_PLIST = new pf__set_symbol_plist();
private static final class pf__set_symbol_plist extends Primitive {
pf__set_symbol_plist() {
super("%set-symbol-plist", PACKAGE_SYS, false);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
checkSymbol(first).setPropertyList(checkList(second));
return second;
}
};
// ### getf plist indicator &optional default => value
private static final Primitive GETF = new pf_getf();
private static final class pf_getf extends Primitive {
pf_getf() {
super(Symbol.GETF, "plist indicator &optional default");
}
@Override
public LispObject execute(LispObject plist, LispObject indicator)
{
return getf(plist, indicator, NIL);
}
@Override
public LispObject execute(LispObject plist, LispObject indicator,
LispObject defaultValue)
{
return getf(plist, indicator, defaultValue);
}
};
// ### get symbol indicator &optional default => value
private static final Primitive GET = new pf_get();
private static final class pf_get extends Primitive {
pf_get() {
super(Symbol.GET, "symbol indicator &optional default");
}
@Override
public LispObject execute(LispObject symbol, LispObject indicator)
{
return get(symbol, indicator, NIL);
}
@Override
public LispObject execute(LispObject symbol, LispObject indicator,
LispObject defaultValue)
{
return get(symbol, indicator, defaultValue);
}
};
// ### put symbol indicator value => value
public static final Primitive PUT = new pf_put();
private static final class pf_put extends Primitive {
pf_put() {
super("put", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject symbol, LispObject indicator,
LispObject value)
{
return put(checkSymbol(symbol), indicator, value);
}
@Override
public LispObject execute(LispObject symbol, LispObject indicator,
LispObject defaultValue, LispObject value)
{
return put(checkSymbol(symbol), indicator, value);
}
};
// ### macrolet
private static final SpecialOperator MACROLET = new sf_macrolet();
private static final class sf_macrolet extends SpecialOperator {
sf_macrolet() {
super(Symbol.MACROLET, "definitions &rest body");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
LispObject defs = checkList(args.car());
final LispThread thread = LispThread.currentThread();
final SpecialBindingsMark mark = thread.markSpecialBindings();
try {
Environment ext = new Environment(env);
while (defs != NIL) {
LispObject def = checkList(defs.car());
Symbol symbol = checkSymbol(def.car());
Symbol make_expander_for_macrolet =
PACKAGE_SYS.intern("MAKE-MACRO-EXPANDER");
LispObject expander =
make_expander_for_macrolet.execute(def);
Closure expansionFunction = new Closure(expander, env);
MacroObject macroObject =
new MacroObject(symbol, expansionFunction);
ext.addFunctionBinding(symbol, macroObject);
defs = defs.cdr();
}
return progn(ext.processDeclarations(args.cdr()), ext, thread);
}
finally {
thread.resetSpecialBindings(mark);
}
}
};
private static final Primitive MAKE_MACRO_EXPANDER = new pf_make_macro_expander();
private static final class pf_make_macro_expander extends Primitive {
pf_make_macro_expander() {
super("make-macro-expander", PACKAGE_SYS, true, "definition");
}
@Override
public LispObject execute(LispObject definition)
{
/* Create an expansion function
* `(lambda (,formArg ,envArg)
* (apply (function (macro-function ,lambdaList
* (block ,symbol ,@body)))
* (cdr ,formArg)))
*/
Symbol symbol = checkSymbol(definition.car());
LispObject lambdaList = definition.cadr();
LispObject body = definition.cddr();
LispObject block =
new Cons(Symbol.BLOCK, new Cons(symbol, body));
LispObject toBeApplied =
list(Symbol.FUNCTION, list(Symbol.MACRO_FUNCTION, lambdaList, block));
final LispThread thread = LispThread.currentThread();
LispObject formArg = gensym("WHOLE-", thread);
LispObject envArg = gensym("ENVIRONMENT-", thread); // Ignored.
LispObject expander =
list(Symbol.LAMBDA, list(formArg, envArg),
list(Symbol.APPLY, toBeApplied,
list(Symbol.CDR, formArg)));
return expander;
}
};
// ### tagbody
private static final SpecialOperator TAGBODY = new sf_tagbody();
private static final class sf_tagbody extends SpecialOperator {
sf_tagbody() {
super(Symbol.TAGBODY, "&rest statements");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
Environment ext = new Environment(env);
try {
return processTagBody(args, preprocessTagBody(args, ext), ext);
}
finally {
ext.inactive = true;
}
}
};
// ### go
private static final SpecialOperator GO = new sf_go();
private static final class sf_go extends SpecialOperator {
sf_go() {
super(Symbol.GO, "tag");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
if (args.length() != 1)
return error(new WrongNumberOfArgumentsException(this, 1));
Binding binding = env.getTagBinding(args.car());
if (binding == null)
return error(new ControlError("No tag named " +
args.car().princToString() +
" is currently visible."));
return nonLocalGo(binding, args.car());
}
};
// ### block
private static final SpecialOperator BLOCK = new sf_block();
private static final class sf_block extends SpecialOperator {
sf_block() {
super(Symbol.BLOCK, "name &rest forms");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
if (args == NIL)
return error(new WrongNumberOfArgumentsException(this, 1, -1));
LispObject tag;
tag = checkSymbol(args.car());
LispObject body = ((Cons)args).cdr();
Environment ext = new Environment(env);
final LispObject block = new LispObject();
ext.addBlock(tag, block);
LispObject result = NIL;
final LispThread thread = LispThread.currentThread();
try {
return progn(body, ext, thread);
} catch (Return ret) {
if (ret.getBlock() == block) {
return ret.getResult();
}
throw ret;
}
finally {
ext.inactive = true;
}
}
};
// ### return-from
private static final SpecialOperator RETURN_FROM = new sf_return_from();
private static final class sf_return_from extends SpecialOperator {
sf_return_from() {
super(Symbol.RETURN_FROM, "name &optional value");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
final int length = args.length();
if (length < 1 || length > 2)
return error(new WrongNumberOfArgumentsException(this, 1, 2));
Symbol symbol;
symbol = checkSymbol(args.car());
return nonLocalReturn(env.getBlockBinding(symbol), symbol,
(length == 2) ? eval(args.cadr(), env,
LispThread.currentThread())
: NIL);
}
};
// ### catch
private static final SpecialOperator CATCH = new sf_catch();
private static final class sf_catch extends SpecialOperator {
sf_catch() {
super(Symbol.CATCH, "tag &body body");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
if (args.length() < 1)
return error(new WrongNumberOfArgumentsException(this, 1, -1));
final LispThread thread = LispThread.currentThread();
LispObject tag = eval(args.car(), env, thread);
thread.pushCatchTag(tag);
LispObject body = args.cdr();
LispObject result = NIL;
try {
return progn(body, env, thread);
} catch (Throw t) {
if (t.tag == tag) {
return t.getResult(thread);
}
throw t;
} catch (Return ret) {
throw ret;
}
finally {
thread.popCatchTag();
}
}
};
// ### throw
private static final SpecialOperator THROW = new sf_throw();
private static final class sf_throw extends SpecialOperator {
sf_throw() {
super(Symbol.THROW, "tag result");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
if (args.length() != 2)
return error(new WrongNumberOfArgumentsException(this, 2));
final LispThread thread = LispThread.currentThread();
thread.throwToTag(eval(args.car(), env, thread),
eval(args.cadr(), env, thread));
// Not reached.
return NIL;
}
};
// ### unwind-protect
private static final SpecialOperator UNWIND_PROTECT = new sf_unwind_protect();
private static final class sf_unwind_protect extends SpecialOperator {
sf_unwind_protect() {
super(Symbol.UNWIND_PROTECT, "protected &body cleanup");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
final LispThread thread = LispThread.currentThread();
LispObject result;
LispObject[] values;
try {
result = eval(args.car(), env, thread);
}
finally {
values = thread._values;
LispObject body = args.cdr();
while (body != NIL) {
eval(body.car(), env, thread);
body = ((Cons)body).cdr;
}
thread._values = values;
}
if (values != null)
thread.setValues(values);
else
thread._values = null;
return result;
}
};
// ### eval-when
private static final SpecialOperator EVAL_WHEN = new sf_eval_when();
private static final class sf_eval_when extends SpecialOperator {
sf_eval_when() {
super(Symbol.EVAL_WHEN, "situations &rest forms");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
LispObject situations = args.car();
if (situations != NIL) {
if (memq(Keyword.EXECUTE, situations) ||
memq(Symbol.EVAL, situations)) {
return progn(args.cdr(), env, LispThread.currentThread());
}
}
return NIL;
}
};
// ### multiple-value-bind
// multiple-value-bind (var*) values-form declaration* form*
// Should be a macro.
private static final SpecialOperator MULTIPLE_VALUE_BIND = new sf_multiple_value_bind();
private static final class sf_multiple_value_bind extends SpecialOperator {
sf_multiple_value_bind() {
super(Symbol.MULTIPLE_VALUE_BIND,
"vars value-form &body body");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
LispObject vars = args.car();
args = args.cdr();
LispObject valuesForm = args.car();
LispObject body = args.cdr();
final LispThread thread = LispThread.currentThread();
LispObject value = eval(valuesForm, env, thread);
LispObject[] values = thread._values;
if (values == null) {
// eval() did not return multiple values.
values = new LispObject[1];
values[0] = value;
}
// Process declarations.
LispObject bodyAndDecls = parseBody(body, false);
LispObject specials = parseSpecials(bodyAndDecls.NTH(1));
body = bodyAndDecls.car();
final SpecialBindingsMark mark = thread.markSpecialBindings();
final Environment ext = new Environment(env);
int i = 0;
LispObject var = vars.car();
while (var != NIL) {
final Symbol sym;
sym = checkSymbol(var);
LispObject val = i < values.length ? values[i] : NIL;
if (specials != NIL && memq(sym, specials)) {
thread.bindSpecial(sym, val);
ext.declareSpecial(sym);
} else if (sym.isSpecialVariable()) {
thread.bindSpecial(sym, val);
} else
ext.bind(sym, val);
vars = vars.cdr();
var = vars.car();
++i;
}
// 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)
while (specials != NIL) {
Symbol symbol = (Symbol) specials.car();
ext.declareSpecial(symbol);
specials = ((Cons)specials).cdr;
}
thread._values = null;
LispObject result = NIL;
try {
result = progn(body, ext, thread);
}
finally {
thread.resetSpecialBindings(mark);
}
return result;
}
};
// ### multiple-value-prog1
private static final SpecialOperator MULTIPLE_VALUE_PROG1 = new sf_multiple_value_prog1();
private static final class sf_multiple_value_prog1 extends SpecialOperator {
sf_multiple_value_prog1() {
super(Symbol.MULTIPLE_VALUE_PROG1,
"values-form &rest forms");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
if (args.length() == 0)
return error(new WrongNumberOfArgumentsException(this, 1, -1));
final LispThread thread = LispThread.currentThread();
LispObject result = eval(args.car(), env, thread);
LispObject[] values = thread._values;
while ((args = args.cdr()) != NIL)
eval(args.car(), env, thread);
if (values != null)
thread.setValues(values);
else
thread._values = null;
return result;
}
};
// ### multiple-value-call
private static final SpecialOperator MULTIPLE_VALUE_CALL = new sf_multiple_value_call();
private static final class sf_multiple_value_call extends SpecialOperator {
sf_multiple_value_call() {
super(Symbol.MULTIPLE_VALUE_CALL, "fun &rest args");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
if (args.length() == 0)
return error(new WrongNumberOfArgumentsException(this, 1, -1));
final LispThread thread = LispThread.currentThread();
LispObject function;
LispObject obj = eval(args.car(), env, thread);
args = args.cdr();
if (obj instanceof Symbol) {
function = obj.getSymbolFunction();
if (function == null)
error(new UndefinedFunction(obj));
} else if (obj instanceof Function) {
function = obj;
} else {
error(new LispError(obj.princToString() +
" is not a function name."));
return NIL;
}
ArrayList arrayList = new ArrayList();
while (args != NIL) {
LispObject form = args.car();
LispObject result = eval(form, env, thread);
LispObject[] values = thread._values;
if (values != null) {
for (int i = 0; i < values.length; i++)
arrayList.add(values[i]);
} else
arrayList.add(result);
args = ((Cons)args).cdr;
}
LispObject[] argv = new LispObject[arrayList.size()];
arrayList.toArray(argv);
return funcall(function, argv, thread);
}
};
// ### and
// Should be a macro.
private static final SpecialOperator AND = new sf_and();
private static final class sf_and extends SpecialOperator {
sf_and() {
super(Symbol.AND, "&rest forms");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
final LispThread thread = LispThread.currentThread();
LispObject result = T;
while (args != NIL) {
result = eval(args.car(), env, thread);
if (result == NIL) {
if (((Cons)args).cdr != NIL) {
// Not the last form.
thread._values = null;
}
break;
}
args = ((Cons)args).cdr;
}
return result;
}
};
// ### or
// Should be a macro.
private static final SpecialOperator OR = new sf_or();
private static final class sf_or extends SpecialOperator {
sf_or() {
super(Symbol.OR, "&rest forms");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
final LispThread thread = LispThread.currentThread();
LispObject result = NIL;
while (args != NIL) {
result = eval(args.car(), env, thread);
if (result != NIL) {
if (((Cons)args).cdr != NIL) {
// Not the last form.
thread._values = null;
}
break;
}
args = ((Cons)args).cdr;
}
return result;
}
};
// ### multiple-value-list form => list
// Evaluates form and creates a list of the multiple values it returns.
// Should be a macro.
private static final SpecialOperator MULTIPLE_VALUE_LIST = new sf_multiple_value_list();
private static final class sf_multiple_value_list extends SpecialOperator {
sf_multiple_value_list() {
super(Symbol.MULTIPLE_VALUE_LIST, "value-form");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
if (args.length() != 1)
return error(new WrongNumberOfArgumentsException(this, 1));
final LispThread thread = LispThread.currentThread();
LispObject result = eval(((Cons)args).car, env, thread);
LispObject[] values = thread._values;
if (values == null)
return new Cons(result);
thread._values = null;
LispObject list = NIL;
for (int i = values.length; i-- > 0;)
list = new Cons(values[i], list);
return list;
}
};
// ### nth-value n form => object
// Evaluates n and then form and returns the nth value returned by form, or
// NIL if n >= number of values returned.
// Should be a macro.
private static final SpecialOperator NTH_VALUE = new sf_nth_value();
private static final class sf_nth_value extends SpecialOperator {
sf_nth_value() {
super(Symbol.NTH_VALUE, "n form");
}
@Override
public LispObject execute(LispObject args, Environment env)
{
if (args.length() != 2)
return error(new WrongNumberOfArgumentsException(this, 2));
final LispThread thread = LispThread.currentThread();
int n = Fixnum.getValue(eval(args.car(), env, thread));
if (n < 0)
n = 0;
LispObject result = eval(args.cadr(), env, thread);
LispObject[] values = thread._values;
thread._values = null;
if (values == null) {
// A single value was returned.
return n == 0 ? result : NIL;
}
if (n < values.length)
return values[n];
return NIL;
}
};
// ### call-count
private static final Primitive CALL_COUNT = new pf_call_count();
private static final class pf_call_count extends Primitive {
pf_call_count() {
super("call-count", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg) {
return Fixnum.getInstance(arg.getCallCount());
}
};
// ### set-call-count
private static final Primitive SET_CALL_COUNT = new pf_set_call_count();
private static final class pf_set_call_count extends Primitive {
pf_set_call_count() {
super("set-call-count", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
first.setCallCount(Fixnum.getValue(second));
return second;
}
};
// ### hot-count
private static final Primitive HOT_COUNT = new pf_hot_count();
private static final class pf_hot_count extends Primitive {
pf_hot_count() {
super("hot-count", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg) {
return Fixnum.getInstance(arg.getHotCount());
}
};
// ### set-hot-count
private static final Primitive SET_HOT_COUNT = new pf_set_hot_count();
private static final class pf_set_hot_count extends Primitive {
pf_set_hot_count() {
super("set-hot-count", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
first.setHotCount(Fixnum.getValue(second));
return second;
}
};
// ### lambda-name
private static final Primitive LAMBDA_NAME = new pf_lambda_name();
private static final class pf_lambda_name extends Primitive {
pf_lambda_name() {
super("lambda-name", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof Operator) {
return ((Operator)arg).getLambdaName();
}
if (arg.typep(Symbol.GENERIC_FUNCTION) != NIL) {
return Symbol.GENERIC_FUNCTION_NAME.execute(arg);
}
if (arg instanceof FuncallableStandardObject) {
return this.execute(((FuncallableStandardObject)arg).function);
}
return type_error(arg, Symbol.FUNCTION);
}
};
// ### %set-lambda-name
private static final Primitive _SET_LAMBDA_NAME = new pf__set_lambda_name();
private static final class pf__set_lambda_name extends Primitive {
pf__set_lambda_name() {
super("%set-lambda-name", PACKAGE_SYS, false);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
if (first instanceof Operator) {
((Operator)first).setLambdaName(second);
return second;
}
// KLUDGE: this isn't fully general, but lots of other stuff
// will break for generic functions that aren't subclasses
// of standard-generic-function as well.
if (first.typep(Symbol.STANDARD_GENERIC_FUNCTION) != NIL) {
((StandardObject)first).setInstanceSlotValue(Symbol.NAME, second);
return second;
}
if (first instanceof FuncallableStandardObject) {
return this.execute(((FuncallableStandardObject)first).function, second);
}
return type_error(first, Symbol.FUNCTION);
}
};
// ### shrink-vector vector new-size => vector
// Destructively alters the vector, changing its length to NEW-SIZE, which
// must be less than or equal to its current length.
// shrink-vector vector new-size => vector
private static final Primitive SHRINK_VECTOR = new pf_shrink_vector();
private static final class pf_shrink_vector extends Primitive {
pf_shrink_vector() {
super("shrink-vector", PACKAGE_SYS, true, "vector new-size");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
checkVector(first).shrink(Fixnum.getValue(second));
return first;
}
};
// ### subseq sequence start &optional end
private static final Primitive SUBSEQ = new pf_subseq();
private static final class pf_subseq extends Primitive {
pf_subseq() {
super(PACKAGE_SYS.intern("%SUBSEQ"), "sequence start &optional end");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return execute(first, second, NIL);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
final int start = Fixnum.getValue(second);
if (start < 0) {
StringBuilder sb = new StringBuilder("Bad start index (");
sb.append(start);
sb.append(").");
error(new TypeError(sb.toString()));
}
int end;
if (third != NIL) {
end = Fixnum.getValue(third);
if (start > end) {
StringBuilder sb = new StringBuilder("Start index (");
sb.append(start);
sb.append(") is greater than end index (");
sb.append(end);
sb.append(") for SUBSEQ.");
error(new TypeError(sb.toString()));
}
} else
end = -1;
if (first.listp())
return list_subseq(first, start, end);
if (first instanceof AbstractVector) {
final AbstractVector v = (AbstractVector) first;
if (end < 0)
end = v.length();
if (start > end) {
StringBuilder sb = new StringBuilder("Start index (");
sb.append(start);
sb.append(") is greater than length of vector (");
sb.append(end);
sb.append(") for SUBSEQ.");
error(new TypeError(sb.toString()));
}
return v.subseq(start, end);
}
return type_error(first, Symbol.SEQUENCE);
}
};
static final LispObject list_subseq(LispObject list, int start,
int end)
{
int index = 0;
LispObject result = NIL;
while (list != NIL) {
if (end >= 0 && index == end)
return result.nreverse();
if (index++ >= start)
result = new Cons(list.car(), result);
list = list.cdr();
}
return result.nreverse();
}
// ### list
private static final Primitive LIST = new pf_list();
private static final class pf_list extends Primitive {
pf_list() {
super(Symbol.LIST, "&rest objects");
}
@Override
public LispObject execute() {
return NIL;
}
@Override
public LispObject execute(LispObject arg) {
return new Cons(arg);
}
@Override
public LispObject execute(LispObject first, LispObject second) {
return new Cons(first, new Cons(second));
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third) {
return new Cons(first, new Cons(second, new Cons(third)));
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third, LispObject fourth) {
return new Cons(first,
new Cons(second,
new Cons(third,
new Cons(fourth))));
}
@Override
public LispObject execute(LispObject[] args) {
LispObject result = NIL;
for (int i = args.length; i-- > 0;)
result = new Cons(args[i], result);
return result;
}
};
// ### list*
private static final Primitive LIST_STAR = new pf_list_star();
private static final class pf_list_star extends Primitive {
pf_list_star() {
super(Symbol.LIST_STAR, "&rest objects");
}
@Override
public LispObject execute() {
return error(new WrongNumberOfArgumentsException(this, 1, -1));
}
@Override
public LispObject execute(LispObject arg) {
return arg;
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return new Cons(first, second);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
return new Cons(first, new Cons(second, third));
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third, LispObject fourth)
{
return new Cons(first,
new Cons(second,
new Cons(third, fourth)));
}
@Override
public LispObject execute(LispObject[] args) {
int i = args.length - 1;
LispObject result = args[i];
while (i-- > 0)
result = new Cons(args[i], result);
return result;
}
};
// ### nreverse
public static final Primitive NREVERSE = new pf_nreverse();
private static final class pf_nreverse extends Primitive {
pf_nreverse() {
super("%NREVERSE", PACKAGE_SYS, false, "sequence");
}
@Override
public LispObject execute (LispObject arg) {
return arg.nreverse();
}
};
// ### nreconc
private static final Primitive NRECONC = new pf_nreconc();
private static final class pf_nreconc extends Primitive {
pf_nreconc() {
super(Symbol.NRECONC, "list tail");
}
@Override
public LispObject execute(LispObject list, LispObject obj)
{
if (list instanceof Cons) {
LispObject list3 = list.cdr();
if (list3 instanceof Cons) {
if (list3.cdr() instanceof Cons) {
LispObject list1 = list3;
LispObject list2 = NIL;
do {
LispObject h = list3.cdr();
list3.setCdr(list2);
list2 = list3;
list3 = h;
} while (list3.cdr() instanceof Cons);
list.setCdr(list2);
list1.setCdr(list3);
}
LispObject h = list.car();
list.setCar(list3.car());
list3.setCar(h);
list3.setCdr(obj);
} else if (list3 == NIL) {
list.setCdr(obj);
} else
type_error(list3, Symbol.LIST);
return list;
} else if (list == NIL)
return obj;
else
return type_error(list, Symbol.LIST);
}
};
// ### reverse
private static final Primitive REVERSE = new pf_reverse();
private static final class pf_reverse extends Primitive {
pf_reverse() {
super("%reverse", PACKAGE_SYS, false, "sequence");
}
@Override
public LispObject execute(LispObject arg) {
return arg.reverse();
}
};
// ### delete-eq item sequence => result-sequence
private static final Primitive DELETE_EQ = new pf_delete_eq();
private static final class pf_delete_eq extends Primitive {
pf_delete_eq() {
super("delete-eq", PACKAGE_SYS, true, "item sequence");
}
@Override
public LispObject execute(LispObject item, LispObject sequence)
{
if (sequence instanceof AbstractVector)
return ((AbstractVector)sequence).deleteEq(item);
else
return LIST_DELETE_EQ.execute(item, sequence);
}
};
// ### delete-eql item seqluence => result-seqluence
private static final Primitive DELETE_EQL = new pf_delete_eql();
private static final class pf_delete_eql extends Primitive {
pf_delete_eql() {
super("delete-eql", PACKAGE_SYS, true, "item sequence");
}
@Override
public LispObject execute(LispObject item, LispObject sequence)
{
if (sequence instanceof AbstractVector)
return ((AbstractVector)sequence).deleteEql(item);
else
return LIST_DELETE_EQL.execute(item, sequence);
}
};
// ### list-delete-eq item list => result-list
static final Primitive LIST_DELETE_EQ = new pf_list_delete_eq();
private static final class pf_list_delete_eq extends Primitive {
pf_list_delete_eq() {
super("list-delete-eq", PACKAGE_SYS, true, "item list");
}
@Override
public LispObject execute(LispObject item, LispObject list)
{
if (list instanceof Cons) {
LispObject tail = list;
LispObject splice = list;
while (tail instanceof Cons) {
LispObject car = tail.car();
if (car == item) {
if (tail.cdr() != NIL) {
LispObject temp = tail;
tail.setCar(temp.cadr());
tail.setCdr(temp.cddr());
} else {
// Last item.
if (tail == list)
return NIL;
splice.setCdr(NIL);
return list;
}
} else {
splice = tail;
tail = tail.cdr();
}
}
if (tail == NIL)
return list;
else
return type_error(tail, Symbol.LIST);
} else if (list == NIL)
return list;
else
return type_error(list, Symbol.LIST);
}
};
// ### list-delete-eql item list => result-list
static final Primitive LIST_DELETE_EQL = new pf_list_delete_eql();
private static final class pf_list_delete_eql extends Primitive {
pf_list_delete_eql() {
super("list-delete-eql", PACKAGE_SYS, true, "item list");
}
@Override
public LispObject execute(LispObject item, LispObject list)
{
if (list instanceof Cons) {
LispObject tail = list;
LispObject splice = list;
while (tail instanceof Cons) {
LispObject car = tail.car();
if (car.eql(item)) {
if (tail.cdr() != NIL) {
LispObject temp = tail;
tail.setCar(temp.cadr());
tail.setCdr(temp.cddr());
} else {
// Last item.
if (tail == list)
return NIL;
splice.setCdr(NIL);
return list;
}
} else {
splice = tail;
tail = tail.cdr();
}
}
if (tail == NIL)
return list;
else
return type_error(tail, Symbol.LIST);
} else if (list == NIL)
return list;
else
return type_error(list, Symbol.LIST);
}
};
// ### vector-delete-eq item vector => result-vector
private static final Primitive VECTOR_DELETE_EQ = new pf_vector_delete_eq();
private static final class pf_vector_delete_eq extends Primitive {
pf_vector_delete_eq() {
super("vector-delete-eq", PACKAGE_SYS, true, "item vector");
}
@Override
public LispObject execute(LispObject item, LispObject vector)
{
checkVector(vector).deleteEq(item);
return vector;
}
};
// ### vector-delete-eql item vector => result-vector
private static final Primitive VECTOR_DELETE_EQL = new pf_vector_delete_eql();
private static final class pf_vector_delete_eql extends Primitive {
pf_vector_delete_eql() {
super("vector-delete-eql", PACKAGE_SYS, true, "item vector");
}
@Override
public LispObject execute(LispObject item, LispObject vector)
{
checkVector(vector).deleteEql(item);
return vector;
}
};
// ### %set-elt
// %setelt sequence index newval => newval
private static final Primitive _SET_ELT = new pf__set_elt();
private static final class pf__set_elt extends Primitive {
pf__set_elt() {
super("%set-elt", PACKAGE_SYS, false);
}
@Override
public LispObject execute(LispObject first, LispObject second,
LispObject third)
{
if (first instanceof AbstractVector) {
((AbstractVector)first).aset(Fixnum.getValue(second), third);
return third;
}
if (first instanceof Cons) {
int index = Fixnum.getValue(second);
if (index < 0)
error(new TypeError());
LispObject list = first;
int i = 0;
while (true) {
if (i == index) {
list.setCar(third);
return third;
}
list = list.cdr();
if (list == NIL)
error(new TypeError());
++i;
}
}
return type_error(first, Symbol.SEQUENCE);
}
};
// ### %make-list
private static final Primitive _MAKE_LIST = new pf__make_list();
private static final class pf__make_list extends Primitive {
pf__make_list() {
super("%make-list", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
int size = Fixnum.getValue(first);
if (size < 0)
return type_error(first, list(Symbol.INTEGER, Fixnum.ZERO,
Symbol.MOST_POSITIVE_FIXNUM.getSymbolValue()));
LispObject result = NIL;
for (int i = size; i-- > 0;)
result = new Cons(second, result);
return result;
}
};
// ### %member item list key test test-not => tail
private static final Primitive _MEMBER = new pf__member();
private static final class pf__member extends Primitive {
pf__member() {
super("%member", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject item, LispObject list,
LispObject key, LispObject test,
LispObject testNot)
{
LispObject tail = checkList(list);
if (test != NIL && testNot != NIL)
error(new LispError("MEMBER: test and test-not both supplied"));
if (testNot == NIL) {
if (test == NIL || test == Symbol.EQL)
test = EQL;
}
if (key == NIL) {
if (test == EQL) {
while (tail instanceof Cons) {
if (item.eql(((Cons)tail).car))
return tail;
tail = ((Cons)tail).cdr;
}
} else if (test != NIL) {
while (tail instanceof Cons) {
LispObject candidate = ((Cons)tail).car;
if (test.execute(item, candidate) != NIL)
return tail;
tail = ((Cons)tail).cdr;
}
} else {
// test == NIL
while (tail instanceof Cons) {
LispObject candidate = ((Cons)tail).car;
if (testNot.execute(item, candidate) == NIL)
return tail;
tail = ((Cons)tail).cdr;
}
}
} else {
// key != NIL
while (tail instanceof Cons) {
LispObject candidate = key.execute(((Cons)tail).car);
if (test != NIL) {
if (test.execute(item, candidate) != NIL)
return tail;
} else {
if (testNot.execute(item, candidate) == NIL)
return tail;
}
tail = ((Cons)tail).cdr;
}
}
if (tail != NIL)
type_error(tail, Symbol.LIST);
return NIL;
}
};
// ### funcall-key function-or-nil element
private static final Primitive FUNCALL_KEY = new pf_funcall_key();
private static final class pf_funcall_key extends Primitive {
pf_funcall_key() {
super("funcall-key", PACKAGE_SYS, false);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
if (first != NIL)
return LispThread.currentThread().execute(first, second);
return second;
}
};
// ### coerce-to-function
private static final Primitive COERCE_TO_FUNCTION = new pf_coerce_to_function();
private static final class pf_coerce_to_function extends Primitive {
pf_coerce_to_function() {
super("coerce-to-function", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg) {
return coerceToFunction(arg);
}
};
// ### make-closure lambda-form environment => closure
private static final Primitive MAKE_CLOSURE = new pf_make_closure();
private static final class pf_make_closure extends Primitive {
pf_make_closure() {
super("make-closure", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
if (first instanceof Cons && ((Cons)first).car == Symbol.LAMBDA) {
final Environment env;
if (second == NIL)
env = new Environment();
else
env = checkEnvironment(second);
return new Closure(first, env);
}
return error(new TypeError("The argument to MAKE-CLOSURE is not a lambda form."));
}
};
// ### streamp
private static final Primitive STREAMP = new pf_streamp();
private static final class pf_streamp extends Primitive {
pf_streamp() {
super(Symbol.STREAMP, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg instanceof Stream ? T : NIL;
}
};
// ### integerp
private static final Primitive INTEGERP = new pf_integerp();
private static final class pf_integerp extends Primitive {
pf_integerp() {
super(Symbol.INTEGERP, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg.INTEGERP();
}
};
// ### evenp
private static final Primitive EVENP = new pf_evenp();
private static final class pf_evenp extends Primitive {
pf_evenp() {
super(Symbol.EVENP, "integer");
}
@Override
public LispObject execute(LispObject arg) {
return arg.EVENP();
}
};
// ### oddp
private static final Primitive ODDP = new pf_oddp();
private static final class pf_oddp extends Primitive {
pf_oddp() {
super(Symbol.ODDP, "integer");
}
@Override
public LispObject execute(LispObject arg) {
return arg.ODDP();
}
};
// ### numberp
private static final Primitive NUMBERP = new pf_numberp();
private static final class pf_numberp extends Primitive {
pf_numberp() {
super(Symbol.NUMBERP, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg.NUMBERP();
}
};
// ### realp
private static final Primitive REALP = new pf_realp();
private static final class pf_realp extends Primitive {
pf_realp() {
super(Symbol.REALP, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg.REALP();
}
};
// ### rationalp
private static final Primitive RATIONALP = new pf_rationalp();
private static final class pf_rationalp extends Primitive {
pf_rationalp() {
super(Symbol.RATIONALP,"object");
}
@Override
public LispObject execute(LispObject arg) {
return arg.RATIONALP();
}
};
// ### complex
private static final Primitive COMPLEX = new pf_complex();
private static final class pf_complex extends Primitive {
pf_complex() {
super(Symbol.COMPLEX, "realpart &optional imagpart");
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof SingleFloat)
return Complex.getInstance(arg, SingleFloat.ZERO);
if (arg instanceof DoubleFloat)
return Complex.getInstance(arg, DoubleFloat.ZERO);
if (arg.realp())
return arg;
return type_error(arg, Symbol.REAL);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
return Complex.getInstance(first, second);
}
};
// ### complexp
private static final Primitive COMPLEXP = new pf_complexp();
private static final class pf_complexp extends Primitive {
pf_complexp() {
super(Symbol.COMPLEXP, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg.COMPLEXP();
}
};
// ### numerator
private static final Primitive NUMERATOR = new pf_numerator();
private static final class pf_numerator extends Primitive {
pf_numerator() {
super(Symbol.NUMERATOR, "rational");
}
@Override
public LispObject execute(LispObject arg) {
return arg.NUMERATOR();
}
};
// ### denominator
private static final Primitive DENOMINATOR = new pf_denominator();
private static final class pf_denominator extends Primitive {
pf_denominator() {
super(Symbol.DENOMINATOR, "rational");
}
@Override
public LispObject execute(LispObject arg) {
return arg.DENOMINATOR();
}
};
// ### realpart
private static final Primitive REALPART = new pf_realpart();
private static final class pf_realpart extends Primitive {
pf_realpart() {
super(Symbol.REALPART, "number");
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof Complex)
return ((Complex)arg).getRealPart();
if (arg.numberp())
return arg;
return type_error(arg, Symbol.NUMBER);
}
};
// ### imagpart
private static final Primitive IMAGPART = new pf_imagpart();
private static final class pf_imagpart extends Primitive {
pf_imagpart() {
super(Symbol.IMAGPART, "number");
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof Complex)
return ((Complex)arg).getImaginaryPart();
return arg.multiplyBy(Fixnum.ZERO);
}
};
// ### integer-length
private static final Primitive INTEGER_LENGTH = new pf_integer_length();
private static final class pf_integer_length extends Primitive {
pf_integer_length() {
super(Symbol.INTEGER_LENGTH, "integer");
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof Fixnum) {
int n = ((Fixnum)arg).value;
if (n < 0)
n = ~n;
int count = 0;
while (n > 0) {
n = n >>> 1;
++count;
}
return Fixnum.getInstance(count);
}
if (arg instanceof Bignum)
return Fixnum.getInstance(((Bignum)arg).value.bitLength());
return type_error(arg, Symbol.INTEGER);
}
};
// ### gcd-2
private static final Primitive GCD_2 = new pf_gcd_2();
private static final class pf_gcd_2 extends Primitive {
pf_gcd_2() {
super("gcd-2", PACKAGE_SYS, false);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
BigInteger n1, n2;
if (first instanceof Fixnum)
n1 = BigInteger.valueOf(((Fixnum)first).value);
else if (first instanceof Bignum)
n1 = ((Bignum)first).value;
else
return type_error(first, Symbol.INTEGER);
if (second instanceof Fixnum)
n2 = BigInteger.valueOf(((Fixnum)second).value);
else if (second instanceof Bignum)
n2 = ((Bignum)second).value;
else
return type_error(second, Symbol.INTEGER);
return number(n1.gcd(n2));
}
};
// ### identity-hash-code
private static final Primitive IDENTITY_HASH_CODE = new pf_identity_hash_code();
private static final class pf_identity_hash_code extends Primitive {
pf_identity_hash_code() {
super("identity-hash-code", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg) {
return Fixnum.getInstance(System.identityHashCode(arg));
}
};
// ### simple-vector-search pattern vector => position
// Searches vector for pattern.
private static final Primitive SIMPLE_VECTOR_SEARCH = new pf_simple_vector_search();
private static final class pf_simple_vector_search extends Primitive {
pf_simple_vector_search() {
super("simple-vector-search", PACKAGE_SYS, false);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
AbstractVector v = checkVector(second);
if (first.length() == 0)
return Fixnum.ZERO;
final int patternLength = first.length();
final int limit = v.length() - patternLength;
if (first instanceof AbstractVector) {
AbstractVector pattern = (AbstractVector) first;
LispObject element = pattern.AREF(0);
for (int i = 0; i <= limit; i++) {
if (v.AREF(i).eql(element)) {
// Found match for first element of pattern.
boolean match = true;
// We've already checked the first element.
int j = i + 1;
for (int k = 1; k < patternLength; k++) {
if (v.AREF(j).eql(pattern.AREF(k))) {
++j;
} else {
match = false;
break;
}
}
if (match)
return Fixnum.getInstance(i);
}
}
} else {
// Pattern is a list.
LispObject element = first.car();
for (int i = 0; i <= limit; i++) {
if (v.AREF(i).eql(element)) {
// Found match for first element of pattern.
boolean match = true;
// We've already checked the first element.
int j = i + 1;
for (LispObject rest = first.cdr(); rest != NIL; rest = rest.cdr()) {
if (v.AREF(j).eql(rest.car())) {
++j;
} else {
match = false;
break;
}
}
if (match)
return Fixnum.getInstance(i);
}
}
}
return NIL;
}
};
// ### uptime
private static final Primitive UPTIME = new pf_uptime();
private static final class pf_uptime extends Primitive {
pf_uptime() {
super("uptime", PACKAGE_EXT, true);
}
@Override
public LispObject execute() {
return number(System.currentTimeMillis() - Main.startTimeMillis);
}
};
// ### built-in-function-p
private static final Primitive BUILT_IN_FUNCTION_P = new pf_built_in_function_p();
private static final class pf_built_in_function_p extends Primitive {
pf_built_in_function_p() {
super("built-in-function-p", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg) {
return checkSymbol(arg).isBuiltInFunction() ? T : NIL;
}
};
// ### inspected-parts
private static final Primitive INSPECTED_PARTS = new pf_inspected_parts();
private static final class pf_inspected_parts extends Primitive {
pf_inspected_parts() {
super("inspected-parts", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg) {
return arg.getParts();
}
};
// ### inspected-description
private static final Primitive INSPECTED_DESCRIPTION = new pf_inspected_description();
private static final class pf_inspected_description extends Primitive {
pf_inspected_description() {
super("inspected-description", PACKAGE_SYS, false);
}
@Override
public LispObject execute(LispObject arg) {
return arg.getDescription();
}
};
// ### symbol-name
public static final Primitive SYMBOL_NAME = new pf_symbol_name();
private static final class pf_symbol_name extends Primitive {
pf_symbol_name() {
super(Symbol.SYMBOL_NAME, "symbol");
}
@Override
public LispObject execute(LispObject arg) {
return checkSymbol(arg).name;
}
};
// ### symbol-package
public static final Primitive SYMBOL_PACKAGE = new pf_symbol_package();
private static final class pf_symbol_package extends Primitive {
pf_symbol_package() {
super(Symbol.SYMBOL_PACKAGE, "symbol");
}
@Override
public LispObject execute(LispObject arg) {
return checkSymbol(arg).getPackage();
}
};
// ### symbol-function
public static final Primitive SYMBOL_FUNCTION = new pf_symbol_function();
private static final class pf_symbol_function extends Primitive {
pf_symbol_function() {
super(Symbol.SYMBOL_FUNCTION, "symbol");
}
@Override
public LispObject execute(LispObject arg) {
LispObject function = checkSymbol(arg).getSymbolFunction();
if (function != null)
return function;
return error(new UndefinedFunction(arg));
}
};
// ### %set-symbol-function
public static final Primitive _SET_SYMBOL_FUNCTION = new pf__set_symbol_function();
private static final class pf__set_symbol_function extends Primitive {
pf__set_symbol_function() {
super("%set-symbol-function", PACKAGE_SYS, false, "symbol function");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
checkSymbol(first).setSymbolFunction(second);
return second;
}
};
// ### symbol-plist
public static final Primitive SYMBOL_PLIST = new pf_symbol_plist();
private static final class pf_symbol_plist extends Primitive {
pf_symbol_plist() {
super(Symbol.SYMBOL_PLIST, "symbol");
}
@Override
public LispObject execute(LispObject arg) {
return checkSymbol(arg).getPropertyList();
}
};
// ### keywordp
public static final Primitive KEYWORDP = new pf_keywordp();
private static final class pf_keywordp extends Primitive {
pf_keywordp() {
super(Symbol.KEYWORDP, "object");
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof Symbol) {
if (checkSymbol(arg).getPackage() == PACKAGE_KEYWORD)
return T;
}
return NIL;
}
};
// ### make-symbol
public static final Primitive MAKE_SYMBOL = new pf_make_symbol();
private static final class pf_make_symbol extends Primitive {
pf_make_symbol() {
super(Symbol.MAKE_SYMBOL, "name");
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof SimpleString)
return new Symbol((SimpleString)arg);
// Not a simple string.
if (arg instanceof AbstractString)
return new Symbol(arg.getStringValue());
return type_error(arg, Symbol.STRING);
}
};
// ### makunbound
public static final Primitive MAKUNBOUND = new pf_makunbound();
private static final class pf_makunbound extends Primitive {
pf_makunbound() {
super(Symbol.MAKUNBOUND, "symbol");
}
@Override
public LispObject execute(LispObject arg) {
checkSymbol(arg).setSymbolValue(null);
return arg;
}
};
// ### %class-name
private static final Primitive _CLASS_NAME = new pf__class_name();
private static final class pf__class_name extends Primitive {
pf__class_name() {
super("%class-name", PACKAGE_SYS, true, "class");
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof LispClass)
return ((LispClass)arg).getName();
return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symName);
}
};
// ### %set-class-name
private static final Primitive _SET_CLASS_NAME = new pf__set_class_name();
private static final class pf__set_class_name extends Primitive {
pf__set_class_name() {
super("%set-class-name", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
if (second instanceof LispClass)
((LispClass)second).setName(checkSymbol(first));
else
((StandardObject)second).setInstanceSlotValue(StandardClass.symName,
checkSymbol(first));
return first;
}
};
// ### class-layout
private static final Primitive CLASS_LAYOUT = new pf__class_layout();
private static final class pf__class_layout extends Primitive {
pf__class_layout() {
super("%class-layout", PACKAGE_SYS, true, "class");
}
@Override
public LispObject execute(LispObject arg) {
Layout layout;
if (arg instanceof LispClass)
layout = ((LispClass)arg).getClassLayout();
else
layout = (Layout)((StandardObject)arg).getInstanceSlotValue(StandardClass.symLayout);
return layout != null ? layout : NIL;
}
};
// ### %set-class-layout
private static final Primitive _SET_CLASS_LAYOUT = new pf__set_class_layout();
private static final class pf__set_class_layout extends Primitive {
pf__set_class_layout() {
super("%set-class-layout", PACKAGE_SYS, true, "class layout");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
if (first == NIL || first instanceof Layout) {
if (second instanceof LispClass)
((LispClass)second).setClassLayout(first);
else
((StandardObject)second).setInstanceSlotValue(StandardClass.symLayout, first);
return first;
}
return type_error(first, Symbol.LAYOUT);
}
};
// ### %class-direct-superclasses
private static final Primitive _CLASS_DIRECT_SUPERCLASSES = new pf__class_direct_superclasses();
private static final class pf__class_direct_superclasses extends Primitive {
pf__class_direct_superclasses() {
super("%class-direct-superclasses", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof LispClass)
return ((LispClass)arg).getDirectSuperclasses();
else
return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSuperclasses);
}
};
// ### %set-class-direct-superclasses
private static final Primitive _SET_CLASS_DIRECT_SUPERCLASSES = new pf__set_class_direct_superclasses();
private static final class pf__set_class_direct_superclasses extends Primitive {
pf__set_class_direct_superclasses() {
super("%set-class-direct-superclasses", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
if (second instanceof LispClass)
((LispClass)second).setDirectSuperclasses(first);
else
((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectSuperclasses, first);
return first;
}
};
// ### %class-direct-subclasses
private static final Primitive _CLASS_DIRECT_SUBCLASSES = new pf__class_direct_subclasses();
private static final class pf__class_direct_subclasses extends Primitive {
pf__class_direct_subclasses() {
super("%class-direct-subclasses", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof LispClass)
return ((LispClass)arg).getDirectSubclasses();
else
return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectSubclasses);
}
};
// ### %set-class-direct-subclasses
private static final Primitive _SET_CLASS_DIRECT_SUBCLASSES = new pf__set_class_direct_subclasses();
private static final class pf__set_class_direct_subclasses extends Primitive {
pf__set_class_direct_subclasses() {
super("%set-class-direct-subclasses", PACKAGE_SYS, true,
"class direct-subclasses");
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
if (second instanceof LispClass)
((LispClass)second).setDirectSubclasses(first);
else
((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectSubclasses, first);
return first;
}
};
// ### %class-precedence-list
private static final Primitive _CLASS_PRECEDENCE_LIST = new pf__class_precedence_list();
private static final class pf__class_precedence_list extends Primitive {
pf__class_precedence_list() {
super("%class-precedence-list", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof LispClass)
return ((LispClass)arg).getCPL();
else
return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symPrecedenceList);
}
};
// ### %set-class-precedence-list
private static final Primitive _SET_CLASS_PRECEDENCE_LIST = new pf__set_class_precedence_list();
private static final class pf__set_class_precedence_list extends Primitive {
pf__set_class_precedence_list() {
super("%set-class-precedence-list", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
if (second instanceof LispClass)
((LispClass)second).setCPL(first);
else
((StandardObject)second).setInstanceSlotValue(StandardClass.symPrecedenceList, first);
return first;
}
};
// ### %class-direct-methods
private static final Primitive _CLASS_DIRECT_METHODS = new pf__class_direct_methods();
private static final class pf__class_direct_methods extends Primitive {
pf__class_direct_methods() {
super("%class-direct-methods", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg)
{
if (arg instanceof LispClass)
return ((LispClass)arg).getDirectMethods();
else
return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symDirectMethods);
}
};
// ### %set-class-direct-methods
private static final Primitive _SET_CLASS_DIRECT_METHODS = new pf__set_class_direct_methods();
private static final class pf__set_class_direct_methods extends Primitive {
pf__set_class_direct_methods() {
super("%set-class-direct-methods", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
if (second instanceof LispClass)
((LispClass)second).setDirectMethods(first);
else
((StandardObject)second).setInstanceSlotValue(StandardClass.symDirectMethods, first);
return first;
}
};
// ### class-documentation
private static final Primitive CLASS_DOCUMENTATION
= new pf_class_documentation();
private static final class pf_class_documentation extends Primitive {
pf_class_documentation() {
super("class-documentation", PACKAGE_MOP, true);
}
@Override
public LispObject execute(LispObject arg)
{
if (arg instanceof LispClass)
return ((LispClass)arg).getDocumentation();
else
return ((StandardObject)arg).getInstanceSlotValue(Symbol._DOCUMENTATION);
}
};
// ### %set-class-documentation
private static final Primitive _SET_CLASS_DOCUMENTATION
= new pf__set_class_documentation();
private static final class pf__set_class_documentation extends Primitive {
pf__set_class_documentation() {
super("%set-class-documentation", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
if (first instanceof LispClass)
((LispClass)first).setDocumentation(second);
else
((StandardObject)first).setInstanceSlotValue(Symbol._DOCUMENTATION, second);
return second;
}
};
// ### %class-finalized-p
private static final Primitive _CLASS_FINALIZED_P = new pf__class_finalized_p();
private static final class pf__class_finalized_p extends Primitive {
pf__class_finalized_p() {
super("%class-finalized-p", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof LispClass)
return ((LispClass)arg).isFinalized() ? T : NIL;
else
return ((StandardObject)arg).getInstanceSlotValue(StandardClass.symFinalizedP);
}
};
// ### %set-class-finalized-p
private static final Primitive _SET_CLASS_FINALIZED_P = new pf__set_class_finalized_p();
private static final class pf__set_class_finalized_p extends Primitive {
pf__set_class_finalized_p() {
super("%set-class-finalized-p", PACKAGE_SYS, true);
}
@Override
public LispObject execute(LispObject first, LispObject second)
{
if (second instanceof LispClass)
((LispClass)second).setFinalized(first != NIL);
else
((StandardObject)second).setInstanceSlotValue(StandardClass.symFinalizedP, first);
return first;
}
};
// ### classp
private static final Primitive CLASSP = new pf_classp();
private static final class pf_classp extends Primitive {
pf_classp() {
super("classp", PACKAGE_EXT, true);
}
@Override
public LispObject execute(LispObject arg) {
return (arg instanceof LispClass) ? T : arg.typep(Symbol.CLASS);
}
};
// ### char-to-utf8 char => octets
private static final Primitive CHAR_TO_UTF8 = new pf_char_to_utf8();
private static final class pf_char_to_utf8 extends Primitive {
pf_char_to_utf8() {
super("char-to-utf8", PACKAGE_EXT, true);
}
@Override
public LispObject execute(LispObject arg) {
final LispCharacter c;
c = checkCharacter( arg);
char[] chars = new char[1];
chars[0] = c.value;
String s = new String(chars);
final byte[] bytes;
try {
bytes = s.getBytes("UTF8");
} catch (java.io.UnsupportedEncodingException e) {
return error(new LispError("UTF8 is not a supported encoding."));
}
LispObject[] objects = new LispObject[bytes.length];
for (int i = bytes.length; i-- > 0;) {
int n = bytes[i];
if (n < 0)
n += 256;
objects[i] = Fixnum.getInstance(n);
}
return new SimpleVector(objects);
}
};
// ### %documentation
private static final Primitive _DOCUMENTATION = new pf__documentation();
private static final class pf__documentation extends Primitive {
pf__documentation() {
super("%documentation", PACKAGE_SYS, true,
"object doc-type");
}
@Override
public LispObject execute(LispObject object, LispObject docType)
{
LispObject doc = object.getDocumentation(docType);
if (doc == NIL) {
if (docType == Symbol.FUNCTION && object instanceof Symbol) {
// Generic functions are handled at lisp-level, not here
LispObject function = object.getSymbolFunction();
if (function != null)
doc = function.getDocumentation(docType);
}
}
return doc;
}
};
// ### %set-documentation
private static final Primitive _SET_DOCUMENTATION = new pf__set_documentation();
private static final class pf__set_documentation extends Primitive {
pf__set_documentation() {
super("%set-documentation", PACKAGE_SYS, true,
"object doc-type documentation");
}
@Override
public LispObject execute(LispObject object, LispObject docType,
LispObject documentation)
{
// Generic functions are handled at lisp-level, not here
object.setDocumentation(docType, documentation);
return documentation;
}
};
// ### %putf
private static final Primitive _PUTF = new pf__putf();
private static final class pf__putf extends Primitive {
pf__putf() {
super("%putf", PACKAGE_SYS, true,
"plist indicator new-value");
}
@Override
public LispObject execute(LispObject plist, LispObject indicator,
LispObject newValue)
{
return putf(plist, indicator, newValue);
}
};
// ### function-plist
private static final Primitive FUNCTION_PLIST = new pf_function_plist();
private static final class pf_function_plist extends Primitive {
pf_function_plist() {
super("function-plist", PACKAGE_SYS, true, "function");
}
@Override
public LispObject execute(LispObject arg) {
return checkFunction(arg).getPropertyList();
}
};
// ### make-keyword
private static final Primitive MAKE_KEYWORD = new pf_make_keyword();
private static final class pf_make_keyword extends Primitive {
pf_make_keyword() {
super("make-keyword", PACKAGE_SYS, true, "symbol");
}
@Override
public LispObject execute(LispObject arg) {
return PACKAGE_KEYWORD.intern(checkSymbol(arg).name);
}
};
// ### standard-object-p object => generalized-boolean
private static final Primitive STANDARD_OBJECT_P = new pf_standard_object_p();
private static final class pf_standard_object_p extends Primitive {
pf_standard_object_p() {
super("standard-object-p", PACKAGE_SYS, true, "object");
}
@Override
public LispObject execute(LispObject arg) {
return arg instanceof StandardObject ? T : NIL;
}
};
// ### copy-tree
private static final Primitive COPY_TREE = new pf_copy_tree();
private static final class pf_copy_tree extends Primitive {
pf_copy_tree() {
super(Symbol.COPY_TREE, "object");
}
@Override
public LispObject execute(LispObject arg) {
if (arg instanceof Cons) {
Cons cons = (Cons) arg;
return new Cons(execute(cons.car), execute(cons.cdr));
} else
return arg;
}
};
/* Added to ABCL because Maxima wants to be able to turn off
* underflow conditions. However, the Hyperspec says we have to
* signal them. So, we went for CLHS compliant with a switch for
* Maxima.
*/
// ### float-underflow-mode
private static final Primitive FLOAT_UNDERFLOW_MODE
= new pf_float_underflow_mode();
private static final class pf_float_underflow_mode extends Primitive {
pf_float_underflow_mode() {
super(Symbol.FLOAT_UNDERFLOW_MODE, "&optional boolean");
}
@Override
public LispObject execute() {
return Lisp.TRAP_UNDERFLOW ? T : NIL;
}
@Override
public LispObject execute(LispObject arg) {
Lisp.TRAP_UNDERFLOW = (arg != NIL);
return arg;
}
};
/* Implemented for symmetry with the underflow variant. */
// ### float-overflow-mode
private static final Primitive FLOAT_OVERFLOW_MODE
= new pf_float_overflow_mode();
private static final class pf_float_overflow_mode extends Primitive {
pf_float_overflow_mode() {
super(Symbol.FLOAT_OVERFLOW_MODE, "&optional boolean");
}
@Override
public LispObject execute() {
return Lisp.TRAP_OVERFLOW ? T : NIL;
}
@Override
public LispObject execute(LispObject arg) {
Lisp.TRAP_OVERFLOW = (arg != NIL);
return arg;
}
};
// ### finalize
private static final Primitive FINALIZE
= new pf_finalize();
private static final class pf_finalize extends Primitive {
pf_finalize() {
super("finalize", PACKAGE_EXT, true, "object function");
}
@Override
public LispObject execute(LispObject obj, final LispObject fun) {
Finalizer.addFinalizer(obj, new Runnable() {
@Override
public void run() {
fun.execute();
}
});
return obj;
}
};
// ### cancel-finalization
private static final Primitive CANCEL_FINALIZATION
= new pf_cancel_finalization();
private static final class pf_cancel_finalization extends Primitive {
pf_cancel_finalization() {
super("cancel-finalization", PACKAGE_EXT, true, "object");
}
@Override
public LispObject execute(LispObject obj) {
Finalizer.clearFinalizers(obj);
return obj;
}
};
private static final Primitive GET_FASL_READTABLE
= new pf_get_fasl_readtable();
private static class pf_get_fasl_readtable extends Primitive {
pf_get_fasl_readtable() {
super("get-fasl-readtable", PACKAGE_SYS, false);
}
@Override
public LispObject execute() {
return FaslReadtable.getInstance();
}
}
}
