/** Reduce a cond expression to some code which, when evaluated,
* gives the value of the cond expression. We do it that way to
* maintain tail recursion. **/
Object reduceCond(Object clauses, Environment env)
{
Object result = null;
for (; ;)
{
if (clauses == null)
{
return(FALSE);
}
Object clause = first(clauses); clauses = rest(clauses);
if (string.Equals(SchemeUtils.first(clause), "else") ||
truth(result = eval(first(clause), env)))
{
if (rest(clause) == null)
{
return(list("quote", result));
}
else if (string.Equals(SchemeUtils.second(clause), "=>"))
{
return(list(third(clause), list("quote", result)));
}
else
{
return(cons("begin", rest(clause)));
}
}
}
}
/** 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((Boolean)x == FALSE));
case BOOLEANQ: return(truth((Boolean)x == TRUE || (Boolean)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 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(new String(SchemeUtils.str(x)));
//////////////// 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(chr((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
: Procedure.proc(x).apply(interp, null));
case MACROEXPAND: return(Macro.macroExpand(interp, x));
case PROCEDUREQ: return(truth(x is Procedure));
case APPLY: return(Procedure.proc(x).apply(interp, listStar(rest(args))));
case MAP: return(map(Procedure.proc(x), rest(args), interp, list(null)));
case FOREACH: return(map(Procedure.proc(x), rest(args), interp, null));
case CALLCC: Exception cc = new Exception();
Continuation proc = new Continuation(cc);
try { return(Procedure.proc(x).apply(interp, list(proc))); }
catch (Exception e)
{
if (e == cc)
{
return(proc.value);
}
else
{
throw e;
}
}
//////////////// SECTION 6.10 INPUT AND OUPUT
case EOFOBJECTQ: return(truth(string.Equals(x, 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 = Procedure.proc(y).apply(interp, list(p)); } finally { if (p != null)
{
p.Close();
}
}
return(z);
case CALLWITHINPUTFILE: InputPort p2 = null;
try { p2 = openInputFile(x);
z = Procedure.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
case CLASS: try { return(Type.GetType(stringify(x, false))); }
catch (Exception e) { return(FALSE); }
case NEW: try { return(Type.GetType(x.ToString()).Assembly.CreateInstance(x.ToString())); }
catch (Exception e) { return(FALSE); }
case EXIT: System.Environment.Exit((x == null) ? 0 : (int)num(x)); return(0);
case LISTSTAR: return(listStar(args));
default: return(error("internal error: unknown primitive: "
+ this + " applied to " + args));
}
}