diff --git a/mps/example/scheme/scheme.c b/mps/example/scheme/scheme.c index 190cc19bd21..fd2473e6e50 100644 --- a/mps/example/scheme/scheme.c +++ b/mps/example/scheme/scheme.c @@ -41,7 +41,6 @@ * - Quasiquote implementation is messy. * - Lots of library. * - \#foo unsatisfactory in read and print - * - tail recursion (pass current function to eval) */ #include @@ -284,6 +283,7 @@ static obj_t obj_error; /* error indicator */ static obj_t obj_true; /* #t, boolean true */ static obj_t obj_false; /* #f, boolean false */ static obj_t obj_undefined; /* undefined result indicator */ +static obj_t obj_tail; /* tail recursion indicator */ /* predefined symbols @@ -1110,40 +1110,53 @@ static obj_t eval(obj_t env, obj_t op_env, obj_t exp); static obj_t eval(obj_t env, obj_t op_env, obj_t exp) { - /* self-evaluating */ - if(TYPE(exp) == TYPE_INTEGER || - (TYPE(exp) == TYPE_SPECIAL && exp != obj_empty) || - TYPE(exp) == TYPE_STRING || - TYPE(exp) == TYPE_CHARACTER) - return exp; - - /* symbol lookup */ - if(TYPE(exp) == TYPE_SYMBOL) { - obj_t binding = lookup(env, exp); - if(binding == obj_undefined) - error("eval: unbound symbol \"%s\"", exp->symbol.string); - return CDR(binding); - } - - /* apply operator or function */ - if(TYPE(exp) == TYPE_PAIR) { + for(;;) { obj_t operator; + obj_t result; + + /* self-evaluating */ + if(TYPE(exp) == TYPE_INTEGER || + (TYPE(exp) == TYPE_SPECIAL && exp != obj_empty) || + TYPE(exp) == TYPE_STRING || + TYPE(exp) == TYPE_CHARACTER) + return exp; + + /* symbol lookup */ + if(TYPE(exp) == TYPE_SYMBOL) { + obj_t binding = lookup(env, exp); + if(binding == obj_undefined) + error("eval: unbound symbol \"%s\"", exp->symbol.string); + return CDR(binding); + } + + if(TYPE(exp) != TYPE_PAIR) { + error("eval: unknown syntax"); + return obj_error; + } + + /* apply operator or function */ if(TYPE(CAR(exp)) == TYPE_SYMBOL) { obj_t binding = lookup(op_env, CAR(exp)); if(binding != obj_undefined) { operator = CDR(binding); assert(TYPE(operator) == TYPE_OPERATOR); - return (*operator->operator.entry)(env, op_env, operator, CDR(exp)); + result = (*operator->operator.entry)(env, op_env, operator, CDR(exp)); + goto found; } } operator = eval(env, op_env, CAR(exp)); unless(TYPE(operator) == TYPE_OPERATOR) error("eval: application of non-function"); - return (*operator->operator.entry)(env, op_env, operator, CDR(exp)); + result = (*operator->operator.entry)(env, op_env, operator, CDR(exp)); + + found: + if (!(TYPE(result) == TYPE_PAIR && CAR(result) == obj_tail)) + return result; + + env = CADR(result); + op_env = CADDR(result); + exp = CAR(CDDDR(result)); } - - error("eval: unknown syntax"); - return obj_error; } @@ -1241,6 +1254,42 @@ static void eval_args_rest(char *name, obj_t env, obj_t op_env, } +/* eval_tail -- return an object that will cause eval to loop + * + * Rather than calling `eval` an operator can return a special object that + * causes a calling `eval` to loop, avoiding using up a C stack frame. + * This implements tail recursion (in a simple way). + */ + +static obj_t eval_tail(obj_t env, obj_t op_env, obj_t exp) +{ + return make_pair(obj_tail, + make_pair(env, + make_pair(op_env, + make_pair(exp, + obj_empty)))); +} + + +/* eval_body -- evaluate a list of expressions, returning last result + * + * This is used for the bodies of forms such as let, begin, etc. where + * a list of expressions is allowed. + */ + +static obj_t eval_body(obj_t env, obj_t op_env, obj_t operator, obj_t body) +{ + for (;;) { + if (TYPE(body) != TYPE_PAIR) + error("%s: illegal expression list", operator->operator.name); + if (CDR(body) == obj_empty) + return eval_tail(env, op_env, CAR(body)); + (void)eval(env, op_env, CAR(body)); + body = CDR(body); + } +} + + /* BUILT-IN OPERATORS */ @@ -1287,7 +1336,7 @@ static obj_t entry_interpret(obj_t env, obj_t op_env, obj_t operator, obj_t oper if(arguments != obj_empty) error("eval: function applied to too few arguments"); - return eval(fun_env, fun_op_env, operator->operator.body); + return eval_tail(fun_env, fun_op_env, operator->operator.body); } @@ -1356,9 +1405,9 @@ static obj_t entry_if(obj_t env, obj_t op_env, obj_t operator, obj_t operands) test = eval(env, op_env, CAR(operands)); /* Anything which is not #f counts as true [R4RS 6.1]. */ if(test != obj_false) - return eval(env, op_env, CADR(operands)); + return eval_tail(env, op_env, CADR(operands)); if(TYPE(CDDR(operands)) == TYPE_PAIR) - return eval(env, op_env, CADDR(operands)); + return eval_tail(env, op_env, CADDR(operands)); return obj_undefined; } @@ -1385,14 +1434,9 @@ static obj_t entry_cond(obj_t env, obj_t op_env, obj_t operator, obj_t operands) } else result = eval(env, op_env, CAR(clause)); if(result != obj_false) { - for(;;) { - clause = CDR(clause); - if(TYPE(clause) != TYPE_PAIR) break; - result = eval(env, op_env, CAR(clause)); - } - if(clause != obj_empty) - error("%s: illegal clause syntax", operator->operator.name); - return result; + if (CDR(clause) == obj_empty) + return result; + return eval_body(env, op_env, operator, CDR(clause)); } operands = CDR(operands); } @@ -1404,15 +1448,18 @@ static obj_t entry_cond(obj_t env, obj_t op_env, obj_t operator, obj_t operands) static obj_t entry_and(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { - while(TYPE(operands) == TYPE_PAIR) { - obj_t test = eval(env, op_env, CAR(operands)); - if(test == obj_false) - return obj_false; + obj_t test; + if (operands == obj_empty) + return obj_true; + do { + if (TYPE(operands) != TYPE_PAIR) + error("%s: illegal syntax", operator->operator.name); + if (CDR(operands) == obj_empty) + return eval_tail(env, op_env, CAR(operands)); + test = eval(env, op_env, CAR(operands)); operands = CDR(operands); - } - if(operands != obj_empty) - error("%s: illegal syntax", operator->operator.name); - return obj_true; + } while (test != obj_false); + return test; } @@ -1420,15 +1467,18 @@ static obj_t entry_and(obj_t env, obj_t op_env, obj_t operator, obj_t operands) static obj_t entry_or(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { - while(TYPE(operands) == TYPE_PAIR) { - obj_t test = eval(env, op_env, CAR(operands)); - if(test != obj_false) - return obj_true; + obj_t test; + if (operands == obj_empty) + return obj_false; + do { + if (TYPE(operands) != TYPE_PAIR) + error("%s: illegal syntax", operator->operator.name); + if (CDR(operands) == obj_empty) + return eval_tail(env, op_env, CAR(operands)); + test = eval(env, op_env, CAR(operands)); operands = CDR(operands); - } - if(operands != obj_empty) - error("%s: illegal syntax", operator->operator.name); - return obj_false; + } while (test == obj_false); + return test; } @@ -1437,7 +1487,7 @@ static obj_t entry_or(obj_t env, obj_t op_env, obj_t operator, obj_t operands) static obj_t entry_let(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { - obj_t inner_env, bindings, result; + obj_t inner_env, bindings; unless(TYPE(operands) == TYPE_PAIR && TYPE(CDR(operands)) == TYPE_PAIR) error("%s: illegal syntax", operator->operator.name); @@ -1455,14 +1505,7 @@ static obj_t entry_let(obj_t env, obj_t op_env, obj_t operator, obj_t operands) } if(bindings != obj_empty) error("%s: illegal bindings list", operator->operator.name); - operands = CDR(operands); - while(TYPE(operands) == TYPE_PAIR) { - result = eval(inner_env, op_env, CAR(operands)); - operands = CDR(operands); - } - if(operands != obj_empty) - error("%s: illegal expression list", operator->operator.name); - return result; + return eval_body(inner_env, op_env, operator, CDR(operands)); } @@ -1471,7 +1514,7 @@ static obj_t entry_let(obj_t env, obj_t op_env, obj_t operator, obj_t operands) static obj_t entry_let_star(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { - obj_t inner_env, bindings, result; + obj_t inner_env, bindings; unless(TYPE(operands) == TYPE_PAIR && TYPE(CDR(operands)) == TYPE_PAIR) error("%s: illegal syntax", operator->operator.name); @@ -1489,14 +1532,7 @@ static obj_t entry_let_star(obj_t env, obj_t op_env, obj_t operator, obj_t opera } if(bindings != obj_empty) error("%s: illegal bindings list", operator->operator.name); - operands = CDR(operands); - while(TYPE(operands) == TYPE_PAIR) { - result = eval(inner_env, op_env, CAR(operands)); - operands = CDR(operands); - } - if(operands != obj_empty) - error("%s: illegal expression list", operator->operator.name); - return result; + return eval_body(inner_env, op_env, operator, CDR(operands)); } @@ -1505,7 +1541,7 @@ static obj_t entry_let_star(obj_t env, obj_t op_env, obj_t operator, obj_t opera static obj_t entry_letrec(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { - obj_t inner_env, bindings, result; + obj_t inner_env, bindings; unless(TYPE(operands) == TYPE_PAIR && TYPE(CDR(operands)) == TYPE_PAIR) error("%s: illegal syntax", operator->operator.name); @@ -1529,14 +1565,7 @@ static obj_t entry_letrec(obj_t env, obj_t op_env, obj_t operator, obj_t operand define(inner_env, CAR(binding), eval(inner_env, op_env, CADR(binding))); bindings = CDR(bindings); } - operands = CDR(operands); - while(TYPE(operands) == TYPE_PAIR) { - result = eval(inner_env, op_env, CAR(operands)); - operands = CDR(operands); - } - if(operands != obj_empty) - error("%s: illegal expression list", operator->operator.name); - return result; + return eval_body(inner_env, op_env, operator, CDR(operands)); } @@ -1699,14 +1728,7 @@ static obj_t entry_lambda(obj_t env, obj_t op_env, obj_t operator, obj_t operand static obj_t entry_begin(obj_t env, obj_t op_env, obj_t operator, obj_t operands) { - obj_t result; - do { - unless(TYPE(operands) == TYPE_PAIR) - error("%s: illegal syntax", operator->operator.name); - result = eval(env, op_env, CAR(operands)); - operands = CDR(operands); - } while(operands != obj_empty); - return result; + return eval_body(env, op_env, operator, operands); } @@ -2335,7 +2357,8 @@ static struct {char *name; obj_t *varp;} sptab[] = { {"#[error]", &obj_error}, {"#t", &obj_true}, {"#f", &obj_false}, - {"#[undefined]", &obj_undefined} + {"#[undefined]", &obj_undefined}, + {"#[tail]", &obj_tail} };