mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-02-20 03:47:34 +00:00
Implemented tail recursion.
Copied from Perforce Change: 179572 ServerID: perforce.ravenbrook.com
This commit is contained in:
Richard Brooksby
parent
3c6dc5d7af
commit
e819bf596f
1 changed files with 109 additions and 86 deletions
|
|
@ -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 <stdio.h>
|
||||
|
|
@ -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}
|
||||
};
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue