Implement "do".

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

mps/example/scheme/r4rs.scm

@@ -96,10 +96,11 @@
         (else (assoc obj (cdr list)))))
 
 
+;; (< x1 x2 x3 ...)
 ;; (<= x1 x2 x3 ...)
 ;; (>= x1 x2 x3 ...)
 ;; These procedures return #t if their arguments are (respectively):
-;; monotonically nondecreasing, or monotonically nonincreasing.
+;; equal, monotonically nondecreasing, or monotonically nonincreasing.
 ;; These predicates are required to be transitive.
 ;; See R4RS 6.5.5.
 
@@ -109,6 +110,7 @@
         ((op (car list) (cadr list)) #f)
         (else (no-fold op (cdr list)))))
 
+(define (= . rest) (and (apply <= rest) (apply >= rest)))
 (define (<= . rest) (no-fold > rest))
 (define (>= . rest) (no-fold < rest))
 

mps/example/scheme/scheme-malloc.c

@@ -5,7 +5,7 @@
  * 
  * TO DO
  * - unbounded integers, other number types.
- * - do, named let.
+ * - named let.
  * - quasiquote: vectors; nested; dotted.
  * - Lots of library.
  * - \#foo unsatisfactory in read and print
@@ -1649,10 +1649,85 @@ static obj_t entry_letrec(obj_t env, obj_t op_env, obj_t operator, obj_t operand
 }
 
 
-/* entry_do -- (do ((<var> <init> <step1>) ...) (<test> <exp> ...) <command> ...) */
-
+/* entry_do -- (do ((<var> <init> <step1>) ...) (<test> <exp> ...) <command> ...) 
+ * Do is an iteration construct. It specifies a set of variables to be
+ * bound, how they are to be initialized at the start, and how they
+ * are to be updated on each iteration. When a termination condition
+ * is met, the loop exits with a specified result value.
+ * See R4RS 4.2.4.
+ */
 static obj_t entry_do(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
 {
+  obj_t inner_env, next_env, bindings;
+  unless(TYPE(operands) == TYPE_PAIR &&
+         TYPE(CDR(operands)) == TYPE_PAIR &&
+         TYPE(CADR(operands)) == TYPE_PAIR)
+    error("%s: illegal syntax", operator->operator.name);
+  inner_env = make_pair(obj_empty, env);
+
+  /* Do expressions are evaluated as follows: The <init> expressions
+     are evaluated (in some unspecified order), the <variable>s are
+     bound to fresh locations, the results of the <init> expressions
+     are stored in the bindings of the <variable>s, and then the
+     iteration phase begins. */
+  bindings = CAR(operands);
+  while(TYPE(bindings) == TYPE_PAIR) {
+    obj_t binding = CAR(bindings);
+    unless(TYPE(binding) == TYPE_PAIR &&
+           TYPE(CAR(binding)) == TYPE_SYMBOL &&
+           TYPE(CDR(binding)) == TYPE_PAIR &&
+           (CDDR(binding) == obj_empty ||
+            (TYPE(CDDR(binding)) == TYPE_PAIR &&
+             CDDDR(binding) == obj_empty)))
+      error("%s: illegal binding", operator->operator.name);
+    define(inner_env, CAR(binding), eval(env, op_env, CADR(binding)));
+    bindings = CDR(bindings);
+  }
+  for(;;) {
+    /* Each iteration begins by evaluating <test>; */
+    obj_t test = CADR(operands);
+    if(eval(inner_env, op_env, CAR(test)) == obj_false) {
+      /* if the result is false (see section see section 6.1
+         Booleans), then the <command> expressions are evaluated in
+         order for effect, */
+      obj_t commands = CDDR(operands);
+      while(TYPE(commands) == TYPE_PAIR) {
+        eval(inner_env, op_env, CAR(commands));
+        commands = CDR(commands);
+      }
+      unless(commands == obj_empty)
+        error("%s: illegal syntax", operator->operator.name);
+
+      /* the <step> expressions are evaluated in some unspecified
+         order, the <variable>s are bound to fresh locations, the
+         results of the <step>s are stored in the bindings of the
+         <variable>s, and the next iteration begins. */
+      bindings = CAR(operands);
+      next_env = make_pair(obj_empty, inner_env);
+      while(TYPE(bindings) == TYPE_PAIR) {
+        obj_t binding = CAR(bindings);
+        unless(CDDR(binding) == obj_empty)
+          define(next_env, CAR(binding), eval(inner_env, op_env, CADDR(binding)));
+        bindings = CDR(bindings);
+      }
+      inner_env = next_env;
+    } else {
+      /* If <test> evaluates to a true value, then the <expression>s
+         are evaluated from left to right and the value of the last
+         <expression> is returned as the value of the do expression.
+         If no <expression>s are present, then the value of the do
+         expression is unspecified. */
+      obj_t result = obj_undefined;
+      test = CDR(test);
+      while(TYPE(test) == TYPE_PAIR) {
+        result = eval(inner_env, op_env, CAR(test));
+        test = CDR(test);
+      }
+      unless(test == obj_empty)
+        error("%s: illegal syntax", operator->operator.name);
+      return result;
+    }
+  }
   error("%s: unimplemented", operator->operator.name);
   return obj_error;
 }

mps/example/scheme/test-r5rs.scm

@@ -403,8 +403,8 @@
 
 ;;; do
 
-;; UNIMPL: (check '(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i)) '#(0 1 2 3 4))
-;; UNIMPL: (check '(let ((x '(1 3 5 7 9))) (do ((x x (cdr x)) (sum 0 (+ sum (car x)))) ((null? x) sum))) '25)
+(check '(do ((vec (make-vector 5)) (i 0 (+ i 1))) ((= i 5) vec) (vector-set! vec i i)) '#(0 1 2 3 4))
+(check '(let ((x '(1 3 5 7 9))) (do ((x x (cdr x)) (sum 0 (+ sum (car x)))) ((null? x) sum))) '25)
 
 ;;; named let