Next: 4 Scheme関数定義の登録．SchemePrimitives.java
Up: ソフトウェア特論 講義資料 JavaによるScheme言語処理系: Jscheme
Previous: 2 Envionmentクラス
PrimitiveクラスはスーパクラスをProcedureクラスとした
クラスです．
Procedureクラスは以下のようになっています．
package jscheme;
/** @author Peter Norvig,
* peter@norvig.com http://www.norvig.com
* Copyright 1998 Peter Norvig,
* see http://www.norvig.com/license.html **/
public abstract class Procedure extends SchemeUtils {
String name = "anonymous procedure";
public String toString() {
return "{" + name + "}";
}
public abstract Object
apply(Scheme interpreter, Object args);
/** Coerces a Scheme object to a procedure. **/
static Procedure proc(Object x) {
if (x instanceof Procedure)
return (Procedure) x;
else
return proc(error("Not a procedure: "
+ stringify(x)));
}
}
Primitiveクラスは以下のようになっています．
charAtは，文字列の中でのある位置の文字を返します．
先頭の位置は0です．
try, finally構文は，try ブロック１ finally ブロック２という形で，ブロッ
ク１内で例外が起こった場合，ブロック２を実行してtryを抜けます．例外が
起こらない場合でも，ブロック２を実行します．common lispでも同様の構文
として，unwind-protectというものがあります．
> (unwind-protect
(progn (print 1) (/ 10 1) (print 2))
(print 3))
1
2
3
2
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);
}
}
generated through LaTeX2HTML. M.Inaba 平成18年5月6日