/** Apply a primitive to a list of arguments. **/
public override 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.Equals(FALSE));
case BOOLEANQ: return truth(x.Equals(TRUE) || x.Equals(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 is Pair);
case LISTQ: return truth(isList(x));
case CXR: for (int i = name.Length-2; i >= 1; i--)
x = (name[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 is String);
case SYMBOLTOSTRING:return sym(x).ToCharArray();
case STRINGTOSYMBOL:return String.Intern(x.ToString());
//////////////// SECTION 6.5 NUMBERS
case NUMBERQ: return truth(x is Double);
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.Ceiling(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.Ceiling(num(x)));
case TRUNCATE: d = num(x);
return num((d < 0.0) ? Math.Ceiling(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 is Char);
case CHARALPHABETICQ: return truth(Char.IsLetter(chr(x)));
case CHARNUMERICQ: return truth(Char.IsDigit(chr(x)));
case CHARWHITESPACEQ: return truth(Char.IsWhiteSpace(chr(x)));
case CHARUPPERCASEQ: return truth(Char.IsUpper(chr(x)));
case CHARLOWERCASEQ: return truth(Char.IsLower(chr(x)));
case CHARTOINTEGER: return (Double)chr(x);
case INTEGERTOCHAR: return (Char)(int)num(x);
case CHARUPCASE: return chr(Char.ToUpper(chr(x)));
case CHARDOWNCASE: return chr(Char.ToLower(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 is 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(SchemeUtils.str(x).Length);
case STRINGREF: return chr(SchemeUtils.str(x)[(int)num(y)]);
case STRINGSET: Object z = third(args); SchemeUtils.str(x)[(int)num(y)] = chr(z);
return z;
case SUBSTRING: int start = (int)num(y), end = (int)num(third(args));
return new String(SchemeUtils.str(x), start, end-start).ToCharArray();
case STRINGAPPEND: return stringAppend(args);
case STRINGTOLIST:
{
Pair result = null;
char[] str2 = SchemeUtils.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 is 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(SchemeUtils.vec(x).Length);
case VECTORREF: return SchemeUtils.vec(x)[(int)num(y)];
case VECTORSET: return SchemeUtils.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 is Procedure)) ? x
: proc(x).apply(interp, null);
case MACROEXPAND: return Macro.macroExpand(interp, x);
case PROCEDUREQ: return truth(x is 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:
{
Exception cc = new Exception();
Continuation cproc = new Continuation(cc);
try { return proc(x).apply(interp, list(cproc)); }
catch (Exception e)
{
if (e == cc) return cproc.value; else throw e;
}
}
//////////////// SECTION 6.10 INPUT AND OUPUT
case EOFOBJECTQ: return truth(x == (Object) InputPort.EOF);
case INPUTPORTQ: return truth(x is InputPort);
case CURRENTINPUTPORT: return interp.input;
case OPENINPUTFILE: return openInputFile(x);
case CLOSEINPUTPORT: return inPort(x, interp).close();
case OUTPUTPORTQ: return truth(x is TextWriter);
case CURRENTOUTPUTPORT: return interp.output;
case OPENOUTPUTFILE: return openOutputFile(x);
case CALLWITHOUTPUTFILE:
{
TextWriter 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).WriteLine();
outPort(x, interp).Flush(); return TRUE;
//////////////// EXTENSIONS
#if false
case CLASS: try { return Class.forName(stringify(x, false)); }
catch (ClassNotFoundException e) { return FALSE; }
case NEW: try { return DotNetMember.toType(x).newInstance(); }
catch (ClassCastException e) { ; }
catch (NoSuchMethodError e) { ; }
catch (InstantiationException e) { ; }
catch (ClassNotFoundException e) { ; }
catch (IllegalAccessException e) { ; }
return FALSE;
case METHOD: return new DotNetMember(stringify(x, false), y,
rest(rest(args)));
#endif
case EXIT: System.Environment.Exit((x == null) ? 0 : (int)num(x)); break;
case LISTSTAR: return listStar(args);
case TIMECALL: GC.Collect();
long startMem = GC.GetTotalMemory(true);
DateTime startTime = DateTime.Now;
Object ans = FALSE;
int nTimes = (y == null ? 1 : (int)num(y));
for (int i = 0; i < nTimes; i++)
{
ans = proc(x).apply(interp, null);
}
TimeSpan time = DateTime.Now - startTime;
long mem = GC.GetTotalMemory(true) - startMem;
return cons(ans, list(list(num(time.Milliseconds), "msec"),
list(num(mem), "bytes")));
default: return error("internal error: unknown primitive: "
+ this + " applied to " + args);
}
return error("internal error.");
}
/** Apply a closure to a list of arguments. **/
public override Object apply(Scheme interpreter, Object args)
{
return interpreter.eval(body, new Environment(parms, args, env));
}
/** Macro expand an expression **/
public static Object macroExpand(Scheme interpreter, Object x)
{
if (!(x is Pair)) return x;
Object fn = interpreter.eval(first(x), interpreter.globalEnvironment);
if (!(fn is Macro)) return x;
return ((Macro)fn).expand(interpreter, (Pair)x, rest(x));
}
/** 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 is Pair)
{
Object x = proc.apply(interp, list(first(args)));
if (accum != null) accum = (Pair) (accum.rest = list(x));
args = rest(args);
}
}
else
{
Procedure car = Procedure.proc(interp.eval("car"));
Procedure cdr = Procedure.proc(interp.eval("cdr"));
while (first(args) is 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);
}