Implemented tail recursion.

Copied from Perforce
 Change: 179572
 ServerID: perforce.ravenbrook.com

1 files changed, 109 insertions, 86 deletions

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 <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}
 };