package jscheme;
import java.io.*;
/** A primitive is a procedure that is defined as part of the Scheme report,
* and is implemented in Java code.
* @author Peter Norvig, peter@norvig.com http://www.norvig.com
* Copyright 1998 Peter Norvig, see http://www.norvig.com/license.html **/
public class Primitive extends Procedure {
int minArgs;
int maxArgs;
int idNumber;
public Primitive(int id, int minArgs, int maxArgs) {
this.idNumber = id;
this.minArgs = minArgs;
this.maxArgs = maxArgs;
}
private static final int EQ = 0, LT = 1, GT = 2, GE = 3, LE = 4, ABS = 5,
EOF_OBJECT = 6, EQQ = 7, EQUALQ = 8, FORCE = 9, CAR = 10,
FLOOR = 11, CEILING = 12, CONS = 13, DIVIDE = 14, LENGTH = 15,
LIST = 16, LISTQ = 17, APPLY = 18, MAX = 19, MIN = 20, MINUS = 21,
NEWLINE = 22, NOT = 23, NULLQ = 24, NUMBERQ = 25, PAIRQ = 26,
PLUS = 27, PROCEDUREQ = 28, READ = 29, CDR = 30, ROUND = 31,
SECOND = 32, SYMBOLQ = 33, TIMES = 34, TRUNCATE = 35, WRITE = 36,
APPEND = 37, BOOLEANQ = 38, SQRT = 39, EXPT = 40, REVERSE = 41,
ASSOC = 42, ASSQ = 43, ASSV = 44, MEMBER = 45, MEMQ = 46,
MEMV = 47, EQVQ = 48, LISTREF = 49, LISTTAIL = 50, STRINQ = 51,
MAKESTRING = 52, STRING = 53, STRINGLENGTH = 54, STRINGREF = 55,
STRINGSET = 56, SUBSTRING = 57, STRINGAPPEND = 58,
STRINGTOLIST = 59, LISTTOSTRING = 60, SYMBOLTOSTRING = 61,
STRINGTOSYMBOL = 62, EXP = 63, LOG = 64, SIN = 65, COS = 66,
TAN = 67, ACOS = 68, ASIN = 69, ATAN = 70, NUMBERTOSTRING = 71,
STRINGTONUMBER = 72, CHARQ = 73, CHARALPHABETICQ = 74,
CHARNUMERICQ = 75, CHARWHITESPACEQ = 76, CHARUPPERCASEQ = 77,
CHARLOWERCASEQ = 78, CHARTOINTEGER = 79, INTEGERTOCHAR = 80,
CHARUPCASE = 81, CHARDOWNCASE = 82, STRINGQ = 83, VECTORQ = 84,
MAKEVECTOR = 85, VECTOR = 86, VECTORLENGTH = 87, VECTORREF = 88,
VECTORSET = 89, LISTTOVECTOR = 90, MAP = 91, FOREACH = 92,
CALLCC = 93, VECTORTOLIST = 94, LOAD = 95, DISPLAY = 96,
INPUTPORTQ = 98, CURRENTINPUTPORT = 99, OPENINPUTFILE = 100,
CLOSEINPUTPORT = 101, OUTPUTPORTQ = 103, CURRENTOUTPUTPORT = 104,
OPENOUTPUTFILE = 105, CLOSEOUTPUTPORT = 106, READCHAR = 107,
PEEKCHAR = 108, EVAL = 109, QUOTIENT = 110, REMAINDER = 111,
MODULO = 112, THIRD = 113, EOFOBJECTQ = 114, GCD = 115, LCM = 116,
CXR = 117, ODDQ = 118, EVENQ = 119, ZEROQ = 120, POSITIVEQ = 121,
NEGATIVEQ = 122, CHARCMP = 123 /* to 127 */,
CHARCICMP = 128 /* to 132 */, STRINGCMP = 133 /* to 137 */,
STRINGCICMP = 138 /* to 142 */, EXACTQ = 143, INEXACTQ = 144,
INTEGERQ = 145, CALLWITHINPUTFILE = 146, CALLWITHOUTPUTFILE = 147;
//////////////// Extensions ////////////////
static final int NEW = -1, CLASS = -2, METHOD = -3, EXIT = -4, SETCAR = -5,
SETCDR = -6, TIMECALL = -11, MACROEXPAND = -12, ERROR = -13,
LISTSTAR = -14;
public static Environment installPrimitives(Environment env) {
int n = Integer.MAX_VALUE;
env
.defPrim("*", TIMES, 0, n)
.defPrim("*", TIMES, 0, n)
.defPrim("+", PLUS, 0, n)
.defPrim("-", MINUS, 1, n)
.defPrim("/", DIVIDE, 1, n)
.defPrim("<", LT, 2, n)
.defPrim("<=", LE, 2, n)
.defPrim("=", EQ, 2, n)
.defPrim(">", GT, 2, n)
.defPrim(">=", GE, 2, n)
.defPrim("abs", ABS, 1)
.defPrim("acos", ACOS, 1)
.defPrim("append", APPEND, 0, n)
.defPrim("apply", APPLY, 2, n)
.defPrim("asin", ASIN, 1)
.defPrim("assoc", ASSOC, 2)
.defPrim("assq", ASSQ, 2)
.defPrim("assv", ASSV, 2)
.defPrim("atan", ATAN, 1)
.defPrim("boolean?", BOOLEANQ, 1)
.defPrim("caaaar", CXR, 1)
.defPrim("caaadr", CXR, 1)
.defPrim("caaar", CXR, 1)
.defPrim("caadar", CXR, 1)
.defPrim("caaddr", CXR, 1)
.defPrim("caadr", CXR, 1)
.defPrim("caar", CXR, 1)
.defPrim("cadaar", CXR, 1)
.defPrim("cadadr", CXR, 1)
.defPrim("cadar", CXR, 1)
.defPrim("caddar", CXR, 1)
.defPrim("cadddr", CXR, 1)
.defPrim("caddr", THIRD, 1)
.defPrim("cadr", SECOND, 1)
.defPrim("call-with-current-continuation", CALLCC, 1)
.defPrim("call-with-input-file", CALLWITHINPUTFILE, 2)
.defPrim("call-with-output-file", CALLWITHOUTPUTFILE, 2)
.defPrim("car", CAR, 1)
.defPrim("cdaaar", CXR, 1)
.defPrim("cdaadr", CXR, 1)
.defPrim("cdaar", CXR, 1)
.defPrim("cdadar", CXR, 1)
.defPrim("cdaddr", CXR, 1)
.defPrim("cdadr", CXR, 1)
.defPrim("cdar", CXR, 1)
.defPrim("cddaar", CXR, 1)
.defPrim("cddadr", CXR, 1)
.defPrim("cddar", CXR, 1)
.defPrim("cdddar", CXR, 1)
.defPrim("cddddr", CXR, 1)
.defPrim("cdddr", CXR, 1)
.defPrim("cddr", CXR, 1)
.defPrim("cdr", CDR, 1)
.defPrim("char->integer", CHARTOINTEGER, 1)
.defPrim("char-alphabetic?",CHARALPHABETICQ, 1)
.defPrim("char-ci<=?", CHARCICMP+LE, 2)
.defPrim("char-ci<?" , CHARCICMP+LT, 2)
.defPrim("char-ci=?" , CHARCICMP+EQ, 2)
.defPrim("char-ci>=?", CHARCICMP+GE, 2)
.defPrim("char-ci>?" , CHARCICMP+GT, 2)
.defPrim("char-downcase", CHARDOWNCASE, 1)
.defPrim("char-lower-case?",CHARLOWERCASEQ, 1)
.defPrim("char-numeric?", CHARNUMERICQ, 1)
.defPrim("char-upcase", CHARUPCASE, 1)
.defPrim("char-upper-case?",CHARUPPERCASEQ, 1)
.defPrim("char-whitespace?",CHARWHITESPACEQ, 1)
.defPrim("char<=?", CHARCMP+LE, 2)
.defPrim("char<?", CHARCMP+LT, 2)
.defPrim("char=?", CHARCMP+EQ, 2)
.defPrim("char>=?", CHARCMP+GE, 2)
.defPrim("char>?", CHARCMP+GT, 2)
.defPrim("char?", CHARQ, 1)
.defPrim("close-input-port", CLOSEINPUTPORT, 1)
.defPrim("close-output-port", CLOSEOUTPUTPORT, 1)
.defPrim("complex?", NUMBERQ, 1)
.defPrim("cons", CONS, 2)
.defPrim("cos", COS, 1)
.defPrim("current-input-port", CURRENTINPUTPORT, 0)
.defPrim("current-output-port", CURRENTOUTPUTPORT, 0)
.defPrim("display", DISPLAY, 1, 2)
.defPrim("eof-object?", EOFOBJECTQ, 1)
.defPrim("eq?", EQQ, 2)
.defPrim("equal?", EQUALQ, 2)
.defPrim("eqv?", EQVQ, 2)
.defPrim("eval", EVAL, 1, 2)
.defPrim("even?", EVENQ, 1)
.defPrim("exact?", INTEGERQ, 1)
.defPrim("exp", EXP, 1)
.defPrim("expt", EXPT, 2)
.defPrim("force", FORCE, 1)
.defPrim("for-each", FOREACH, 1, n)
.defPrim("gcd", GCD, 0, n)
.defPrim("inexact?", INEXACTQ, 1)
.defPrim("input-port?", INPUTPORTQ, 1)
.defPrim("integer->char", INTEGERTOCHAR, 1)
.defPrim("integer?", INTEGERQ, 1)
.defPrim("lcm", LCM, 0, n)
.defPrim("length", LENGTH, 1)
.defPrim("list", LIST, 0, n)
.defPrim("list->string", LISTTOSTRING, 1)
.defPrim("list->vector", LISTTOVECTOR, 1)
.defPrim("list-ref", LISTREF, 2)
.defPrim("list-tail", LISTTAIL, 2)
.defPrim("list?", LISTQ, 1)
.defPrim("load", LOAD, 1)
.defPrim("log", LOG, 1)
.defPrim("macro-expand", MACROEXPAND,1)
.defPrim("make-string", MAKESTRING,1, 2)
.defPrim("make-vector", MAKEVECTOR,1, 2)
.defPrim("map", MAP, 1, n)
.defPrim("max", MAX, 1, n)
.defPrim("member", MEMBER, 2)
.defPrim("memq", MEMQ, 2)
.defPrim("memv", MEMV, 2)
.defPrim("min", MIN, 1, n)
.defPrim("modulo", MODULO, 2)
.defPrim("negative?", NEGATIVEQ, 1)
.defPrim("newline", NEWLINE, 0, 1)
.defPrim("not", NOT, 1)
.defPrim("null?", NULLQ, 1)
.defPrim("number->string", NUMBERTOSTRING, 1, 2)
.defPrim("number?", NUMBERQ, 1)
.defPrim("odd?", ODDQ, 1)
.defPrim("open-input-file",OPENINPUTFILE, 1)
.defPrim("open-output-file", OPENOUTPUTFILE, 1)
.defPrim("output-port?", OUTPUTPORTQ, 1)
.defPrim("pair?", PAIRQ, 1)
.defPrim("peek-char", PEEKCHAR, 0, 1)
.defPrim("positive?", POSITIVEQ, 1)
.defPrim("procedure?", PROCEDUREQ,1)
.defPrim("quotient", QUOTIENT, 2)
.defPrim("rational?", INTEGERQ, 1)
.defPrim("read", READ, 0, 1)
.defPrim("read-char", READCHAR, 0, 1)
.defPrim("real?", NUMBERQ, 1)
.defPrim("remainder", REMAINDER, 2)
.defPrim("reverse", REVERSE, 1)
.defPrim("round", ROUND, 1)
.defPrim("set-car!", SETCAR, 2)
.defPrim("set-cdr!", SETCDR, 2)
.defPrim("sin", SIN, 1)
.defPrim("sqrt", SQRT, 1)
.defPrim("string", STRING, 0, n)
.defPrim("string->list", STRINGTOLIST, 1)
.defPrim("string->number", STRINGTONUMBER, 1, 2)
.defPrim("string->symbol", STRINGTOSYMBOL, 1)
.defPrim("string-append", STRINGAPPEND, 0, n)
.defPrim("string-ci<=?", STRINGCICMP+LE, 2)
.defPrim("string-ci<?" , STRINGCICMP+LT, 2)
.defPrim("string-ci=?" , STRINGCICMP+EQ, 2)
.defPrim("string-ci>=?", STRINGCICMP+GE, 2)
.defPrim("string-ci>?" , STRINGCICMP+GT, 2)
.defPrim("string-length", STRINGLENGTH, 1)
.defPrim("string-ref", STRINGREF, 2)
.defPrim("string-set!", STRINGSET, 3)
.defPrim("string<=?", STRINGCMP+LE, 2)
.defPrim("string<?", STRINGCMP+LT, 2)
.defPrim("string=?", STRINGCMP+EQ, 2)
.defPrim("string>=?", STRINGCMP+GE, 2)
.defPrim("string>?", STRINGCMP+GT, 2)
.defPrim("string?", STRINGQ, 1)
.defPrim("substring", SUBSTRING, 3)
.defPrim("symbol->string", SYMBOLTOSTRING, 1)
.defPrim("symbol?", SYMBOLQ, 1)
.defPrim("tan", TAN, 1)
.defPrim("vector", VECTOR, 0, n)
.defPrim("vector->list", VECTORTOLIST, 1)
.defPrim("vector-length", VECTORLENGTH, 1)
.defPrim("vector-ref", VECTORREF, 2)
.defPrim("vector-set!", VECTORSET, 3)
.defPrim("vector?", VECTORQ, 1)
.defPrim("write", WRITE, 1, 2)
.defPrim("write-char", DISPLAY, 1, 2)
.defPrim("zero?", ZEROQ, 1)
///////////// Extensions ////////////////
.defPrim("new", NEW, 1)
.defPrim("class", CLASS, 1)
.defPrim("method", METHOD, 2, n)
.defPrim("exit", EXIT, 0, 1)
.defPrim("error", ERROR, 0, n)
.defPrim("time-call", TIMECALL, 1, 2)
.defPrim("_list*", LISTSTAR, 0, n)
;
return env;
}
/** Apply a primitive to a list of arguments. **/
public Object apply(Scheme interp, Object args) {
//First make sure there are the right number of arguments.
int nArgs = length(args);
if (nArgs < minArgs)
return error("too few args, " + nArgs + ", for " + this.name + ": "
+ args);
else if (nArgs > maxArgs)
return error("too many args, " + nArgs + ", for " + this.name
+ ": " + args);
Object x = first(args);
Object y = second(args);
switch (idNumber) {
//////////////// SECTION 6.1 BOOLEANS
case NOT:
return truth(x == FALSE);
case BOOLEANQ:
return truth(x == TRUE || x == FALSE);
//////////////// SECTION 6.2 EQUIVALENCE PREDICATES
case EQVQ:
return truth(eqv(x, y));
case EQQ:
return truth(x == y);
case EQUALQ:
return truth(equal(x, y));
//////////////// SECTION 6.3 LISTS AND PAIRS
case PAIRQ:
return truth(x instanceof Pair);
case LISTQ:
return truth(isList(x));
case CXR:
for (int i = name.length() - 2; i >= 1; i--)
x = (name.charAt(i) == 'a') ? first(x) : rest(x);
return x;
case CONS:
return cons(x, y);
case CAR:
return first(x);
case CDR:
return rest(x);
case SETCAR:
return setFirst(x, y);
case SETCDR:
return setRest(x, y);
case SECOND:
return second(x);
case THIRD:
return third(x);
case NULLQ:
return truth(x == null);
case LIST:
return args;
case LENGTH:
return num(length(x));
case APPEND:
return (args == null) ? null : append(args);
case REVERSE:
return reverse(x);
case LISTTAIL:
for (int k = (int) num(y); k > 0; k--)
x = rest(x);
return x;
case LISTREF:
for (int k = (int) num(y); k > 0; k--)
x = rest(x);
return first(x);
case MEMQ:
return memberAssoc(x, y, 'm', 'q');
case MEMV:
return memberAssoc(x, y, 'm', 'v');
case MEMBER:
return memberAssoc(x, y, 'm', ' ');
case ASSQ:
return memberAssoc(x, y, 'a', 'q');
case ASSV:
return memberAssoc(x, y, 'a', 'v');
case ASSOC:
return memberAssoc(x, y, 'a', ' ');
//////////////// SECTION 6.4 SYMBOLS
case SYMBOLQ:
return truth(x instanceof String);
case SYMBOLTOSTRING:
return sym(x).toCharArray();
case STRINGTOSYMBOL:
return new String(str(x)).intern();
//////////////// SECTION 6.5 NUMBERS
case NUMBERQ:
return truth(x instanceof Number);
case ODDQ:
return truth(Math.abs(num(x)) % 2 != 0);
case EVENQ:
return truth(Math.abs(num(x)) % 2 == 0);
case ZEROQ:
return truth(num(x) == 0);
case POSITIVEQ:
return truth(num(x) > 0);
case NEGATIVEQ:
return truth(num(x) < 0);
case INTEGERQ:
return truth(isExact(x));
case INEXACTQ:
return truth(!isExact(x));
case LT:
return numCompare(args, '<');
case GT:
return numCompare(args, '>');
case EQ:
return numCompare(args, '=');
case LE:
return numCompare(args, 'L');
case GE:
return numCompare(args, 'G');
case MAX:
return numCompute(args, 'X', num(x));
case MIN:
return numCompute(args, 'N', num(x));
case PLUS:
return numCompute(args, '+', 0.0);
case MINUS:
return numCompute(rest(args), '-', num(x));
case TIMES:
return numCompute(args, '*', 1.0);
case DIVIDE:
return numCompute(rest(args), '/', num(x));
case QUOTIENT:
double d = num(x) / num(y);
return num(d > 0 ? Math.floor(d) : Math.ceil(d));
case REMAINDER:
return num((long) num(x) % (long) num(y));
case MODULO:
long xi = (long) num(x),
yi = (long) num(y),
m = xi % yi;
return num((xi * yi > 0 || m == 0) ? m : m + yi);
case ABS:
return num(Math.abs(num(x)));
case FLOOR:
return num(Math.floor(num(x)));
case CEILING:
return num(Math.ceil(num(x)));
case TRUNCATE:
d = num(x);
return num((d < 0.0) ? Math.ceil(d) : Math.floor(d));
case ROUND:
return num(Math.round(num(x)));
case EXP:
return num(Math.exp(num(x)));
case LOG:
return num(Math.log(num(x)));
case SIN:
return num(Math.sin(num(x)));
case COS:
return num(Math.cos(num(x)));
case TAN:
return num(Math.tan(num(x)));
case ASIN:
return num(Math.asin(num(x)));
case ACOS:
return num(Math.acos(num(x)));
case ATAN:
return num(Math.atan(num(x)));
case SQRT:
return num(Math.sqrt(num(x)));
case EXPT:
return num(Math.pow(num(x), num(y)));
case NUMBERTOSTRING:
return numberToString(x, y);
case STRINGTONUMBER:
return stringToNumber(x, y);
case GCD:
return (args == null) ? ZERO : gcd(args);
case LCM:
return (args == null) ? ONE : lcm(args);
//////////////// SECTION 6.6 CHARACTERS
case CHARQ:
return truth(x instanceof Character);
case CHARALPHABETICQ:
return truth(Character.isLetter(chr(x)));
case CHARNUMERICQ:
return truth(Character.isDigit(chr(x)));
case CHARWHITESPACEQ:
return truth(Character.isWhitespace(chr(x)));
case CHARUPPERCASEQ:
return truth(Character.isUpperCase(chr(x)));
case CHARLOWERCASEQ:
return truth(Character.isLowerCase(chr(x)));
case CHARTOINTEGER:
return new Double((double) chr(x));
case INTEGERTOCHAR:
return chr((char) (int) num(x));
case CHARUPCASE:
return chr(Character.toUpperCase(chr(x)));
case CHARDOWNCASE:
return chr(Character.toLowerCase(chr(x)));
case CHARCMP + EQ:
return truth(charCompare(x, y, false) == 0);
case CHARCMP + LT:
return truth(charCompare(x, y, false) < 0);
case CHARCMP + GT:
return truth(charCompare(x, y, false) > 0);
case CHARCMP + GE:
return truth(charCompare(x, y, false) >= 0);
case CHARCMP + LE:
return truth(charCompare(x, y, false) <= 0);
case CHARCICMP + EQ:
return truth(charCompare(x, y, true) == 0);
case CHARCICMP + LT:
return truth(charCompare(x, y, true) < 0);
case CHARCICMP + GT:
return truth(charCompare(x, y, true) > 0);
case CHARCICMP + GE:
return truth(charCompare(x, y, true) >= 0);
case CHARCICMP + LE:
return truth(charCompare(x, y, true) <= 0);
case ERROR:
return error(stringify(args));
//////////////// SECTION 6.7 STRINGS
case STRINGQ:
return truth(x instanceof char[]);
case MAKESTRING:
char[] str = new char[(int) num(x)];
if (y != null) {
char c = chr(y);
for (int i = str.length - 1; i >= 0; i--)
str[i] = c;
}
return str;
case STRING:
return listToString(args);
case STRINGLENGTH:
return num(str(x).length);
case STRINGREF:
return chr(str(x)[(int) num(y)]);
case STRINGSET:
Object z = third(args);
str(x)[(int) num(y)] = chr(z);
return z;
case SUBSTRING:
int start = (int) num(y),
end = (int) num(third(args));
return new String(str(x), start, end - start).toCharArray();
case STRINGAPPEND:
return stringAppend(args);
case STRINGTOLIST:
Pair result = null;
char[] str2 = str(x);
for (int i = str2.length - 1; i >= 0; i--)
result = cons(chr(str2[i]), result);
return result;
case LISTTOSTRING:
return listToString(x);
case STRINGCMP + EQ:
return truth(stringCompare(x, y, false) == 0);
case STRINGCMP + LT:
return truth(stringCompare(x, y, false) < 0);
case STRINGCMP + GT:
return truth(stringCompare(x, y, false) > 0);
case STRINGCMP + GE:
return truth(stringCompare(x, y, false) >= 0);
case STRINGCMP + LE:
return truth(stringCompare(x, y, false) <= 0);
case STRINGCICMP + EQ:
return truth(stringCompare(x, y, true) == 0);
case STRINGCICMP + LT:
return truth(stringCompare(x, y, true) < 0);
case STRINGCICMP + GT:
return truth(stringCompare(x, y, true) > 0);
case STRINGCICMP + GE:
return truth(stringCompare(x, y, true) >= 0);
case STRINGCICMP + LE:
return truth(stringCompare(x, y, true) <= 0);
//////////////// SECTION 6.8 VECTORS
case VECTORQ:
return truth(x instanceof Object[]);
case MAKEVECTOR:
Object[] vec = new Object[(int) num(x)];
if (y != null) {
for (int i = 0; i < vec.length; i++)
vec[i] = y;
}
return vec;
case VECTOR:
return listToVector(args);
case VECTORLENGTH:
return num(vec(x).length);
case VECTORREF:
return vec(x)[(int) num(y)];
case VECTORSET:
return vec(x)[(int) num(y)] = third(args);
case VECTORTOLIST:
return vectorToList(x);
case LISTTOVECTOR:
return listToVector(x);
//////////////// SECTION 6.9 CONTROL FEATURES
case EVAL:
return interp.eval(x);
case FORCE:
return (!(x instanceof Procedure)) ? x : proc(x)
.apply(interp, null);
case MACROEXPAND:
return Macro.macroExpand(interp, x);
case PROCEDUREQ:
return truth(x instanceof Procedure);
case APPLY:
return proc(x).apply(interp, listStar(rest(args)));
case MAP:
return map(proc(x), rest(args), interp, list(null));
case FOREACH:
return map(proc(x), rest(args), interp, null);
case CALLCC:
RuntimeException cc = new RuntimeException();
Continuation proc = new Continuation(cc);
try {
return proc(x).apply(interp, list(proc));
} catch (RuntimeException e) {
if (e == cc)
return proc.value;
else
throw e;
}
//////////////// SECTION 6.10 INPUT AND OUPUT
case EOFOBJECTQ:
return truth(x == InputPort.EOF);
case INPUTPORTQ:
return truth(x instanceof InputPort);
case CURRENTINPUTPORT:
return interp.input;
case OPENINPUTFILE:
return openInputFile(x);
case CLOSEINPUTPORT:
return inPort(x, interp).close();
case OUTPUTPORTQ:
return truth(x instanceof PrintWriter);
case CURRENTOUTPUTPORT:
return interp.output;
case OPENOUTPUTFILE:
return openOutputFile(x);
case CALLWITHOUTPUTFILE:
PrintWriter p = null;
try {
p = openOutputFile(x);
z = proc(y).apply(interp, list(p));
} finally {
if (p != null)
p.close();
}
return z;
case CALLWITHINPUTFILE:
InputPort p2 = null;
try {
p2 = openInputFile(x);
z = proc(y).apply(interp, list(p2));
} finally {
if (p2 != null)
p2.close();
}
return z;
case CLOSEOUTPUTPORT:
outPort(x, interp).close();
return TRUE;
case READCHAR:
return inPort(x, interp).readChar();
case PEEKCHAR:
return inPort(x, interp).peekChar();
case LOAD:
return interp.load(x);
case READ:
return inPort(x, interp).read();
case EOF_OBJECT:
return truth(InputPort.isEOF(x));
case WRITE:
return write(x, outPort(y, interp), true);
case DISPLAY:
return write(x, outPort(y, interp), false);
case NEWLINE:
outPort(x, interp).println();
outPort(x, interp).flush();
return TRUE;
//////////////// EXTENSIONS
case CLASS:
try {
return Class.forName(stringify(x, false));
} catch (ClassNotFoundException e) {
return FALSE;
}
case NEW:
try {
return JavaMethod.toClass(x).newInstance();
} catch (ClassCastException e) {
;
} catch (NoSuchMethodError e) {
;
} catch (InstantiationException e) {
;
} catch (ClassNotFoundException e) {
;
} catch (IllegalAccessException e) {
;
}
return FALSE;
case METHOD:
return new JavaMethod(stringify(x, false), y, rest(rest(args)));
case EXIT:
System.exit((x == null) ? 0 : (int) num(x));
case LISTSTAR:
return listStar(args);
case TIMECALL:
Runtime runtime = Runtime.getRuntime();
runtime.gc();
long startTime = System.currentTimeMillis();
long startMem = runtime.freeMemory();
Object ans = FALSE;
int nTimes = (y == null ? 1 : (int) num(y));
for (int i = 0; i < nTimes; i++) {
ans = proc(x).apply(interp, null);
}
long time = System.currentTimeMillis() - startTime;
long mem = startMem - runtime.freeMemory();
return cons(ans, list(list(num(time), "msec"), list(num(mem),
"bytes")));
default:
return error("internal error: unknown primitive: " + this
+ " applied to " + args);
}
}
public static char[] stringAppend(Object args) {
StringBuffer result = new StringBuffer();
for (; args instanceof Pair; args = rest(args)) {
result.append(stringify(first(args), false));
}
return result.toString().toCharArray();
}
public static Object memberAssoc(Object obj, Object list, char m, char eq) {
while (list instanceof Pair) {
Object target = (m == 'm') ? first(list) : first(first(list));
boolean found;
switch (eq) {
case 'q':
found = (target == obj);
break;
case 'v':
found = eqv(target, obj);
break;
case ' ':
found = equal(target, obj);
break;
default:
warn("Bad option to memberAssoc:" + eq);
return FALSE;
}
if (found)
return (m == 'm') ? list : first(list);
list = rest(list);
}
return FALSE;
}
public static Object numCompare(Object args, char op) {
while (rest(args) instanceof Pair) {
double x = num(first(args));
args = rest(args);
double y = num(first(args));
switch (op) {
case '>':
if (!(x > y))
return FALSE;
break;
case '<':
if (!(x < y))
return FALSE;
break;
case '=':
if (!(x == y))
return FALSE;
break;
case 'L':
if (!(x <= y))
return FALSE;
break;
case 'G':
if (!(x >= y))
return FALSE;
break;
default:
error("internal error: unrecognized op: " + op);
break;
}
}
return TRUE;
}
public static Object numCompute(Object args, char op, double result) {
if (args == null) {
switch (op) {
case '-':
return num(0 - result);
case '/':
return num(1 / result);
default:
return num(result);
}
} else {
while (args instanceof Pair) {
double x = num(first(args));
args = rest(args);
switch (op) {
case 'X':
if (x > result)
result = x;
break;
case 'N':
if (x < result)
result = x;
break;
case '+':
result += x;
break;
case '-':
result -= x;
break;
case '*':
result *= x;
break;
case '/':
result /= x;
break;
default:
error("internal error: unrecognized op: " + op);
break;
}
}
return num(result);
}
}
/** Return the sign of the argument: +1, -1, or 0. **/
static int sign(int x) {
return (x > 0) ? +1 : (x < 0) ? -1 : 0;
}
/** Return <0 if x is alphabetically first, >0 if y is first,
* 0 if same. Case insensitive iff ci is true. Error if not both chars. **/
public static int charCompare(Object x, Object y, boolean ci) {
char xc = chr(x), yc = chr(y);
if (ci) {
xc = Character.toLowerCase(xc);
yc = Character.toLowerCase(yc);
}
return xc - yc;
}
/** Return <0 if x is alphabetically first, >0 if y is first,
* 0 if same. Case insensitive iff ci is true. Error if not strings. **/
public static int stringCompare(Object x, Object y, boolean ci) {
if (x instanceof char[] && y instanceof char[]) {
char[] xc = (char[]) x, yc = (char[]) y;
for (int i = 0; i < xc.length; i++) {
int diff = (!ci) ? xc[i] - yc[i] : Character.toUpperCase(xc[i])
- Character.toUpperCase(yc[i]);
if (diff != 0)
return diff;
}
return xc.length - yc.length;
} else {
error("expected two strings, got: " + stringify(list(x, y)));
return 0;
}
}
static Object numberToString(Object x, Object y) {
int base = (y instanceof Number) ? (int) num(y) : 10;
if (base != 10 || num(x) == Math.round(num(x))) {
// An integer
return Long.toString((long) num(x), base).toCharArray();
} else {
// A floating point number
return x.toString().toCharArray();
}
}
static Object stringToNumber(Object x, Object y) {
int base = (y instanceof Number) ? (int) num(y) : 10;
try {
return (base == 10) ? Double.valueOf(stringify(x, false))
: num(Long.parseLong(stringify(x, false), base));
} catch (NumberFormatException e) {
return FALSE;
}
}
static Object gcd(Object args) {
long gcd = 0;
while (args instanceof Pair) {
gcd = gcd2(Math.abs((long) num(first(args))), gcd);
args = rest(args);
}
return num(gcd);
}
static long gcd2(long a, long b) {
if (b == 0)
return a;
else
return gcd2(b, a % b);
}
static Object lcm(Object args) {
long L = 1, g = 1;
while (args instanceof Pair) {
long n = Math.abs((long) num(first(args)));
g = gcd2(n, L);
L = (g == 0) ? g : (n / g) * L;
args = rest(args);
}
return num(L);
}
static boolean isExact(Object x) {
if (!(x instanceof Double))
return false;
double d = num(x);
return (d == Math.round(d) && Math.abs(d) < 102962884861573423.0);
}
static PrintWriter openOutputFile(Object filename) {
try {
return new PrintWriter(new FileWriter(stringify(filename, false)));
} catch (FileNotFoundException e) {
return (PrintWriter) error("No such file: " + stringify(filename));
} catch (IOException e) {
return (PrintWriter) error("IOException: " + e);
}
}
static InputPort openInputFile(Object filename) {
try {
return new InputPort(
new FileInputStream(stringify(filename, false)));
} catch (FileNotFoundException e) {
return (InputPort) error("No such file: " + stringify(filename));
} catch (IOException e) {
return (InputPort) error("IOException: " + e);
}
}
static boolean isList(Object x) {
Object slow = x, fast = x;
for (;;) {
if (fast == null)
return true;
if (slow == rest(fast) || !(fast instanceof Pair)
|| !(slow instanceof Pair))
return false;
slow = rest(slow);
fast = rest(fast);
if (fast == null)
return true;
if (!(fast instanceof Pair))
return false;
fast = rest(fast);
}
}
static Object append(Object args) {
if (rest(args) == null)
return first(args);
else
return append2(first(args), append(rest(args)));
}
static Object append2(Object x, Object y) {
if (x instanceof Pair)
return cons(first(x), append2(rest(x), y));
else
return y;
}
/** Map proc over a list of lists of args, in the given interpreter.
* If result is non-null, accumulate the results of each call there
* and return that at the end. Otherwise, just return null. **/
static Pair map(Procedure proc, Object args, Scheme interp, Pair result) {
Pair accum = result;
if (rest(args) == null) {
args = first(args);
while (args instanceof Pair) {
Object x = proc.apply(interp, list(first(args)));
if (accum != null)
accum = (Pair) (accum.rest = list(x));
args = rest(args);
}
} else {
Procedure car = proc(interp.eval("car")), cdr = proc(interp
.eval("cdr"));
while (first(args) instanceof Pair) {
Object x = proc.apply(interp, map(car, list(args), interp,
list(null)));
if (accum != null)
accum = (Pair) (accum.rest = list(x));
args = map(cdr, list(args), interp, list(null));
}
}
return (Pair) rest(result);
}
}