From fd03ed65aa855eae85e423383e25b691eb3bf835 Mon Sep 17 00:00:00 2001 From: Gareth Rees Date: Sun, 11 Nov 2012 19:34:46 +0000 Subject: [PATCH] Implement "do". Copied from Perforce Change: 180441 ServerID: perforce.ravenbrook.com --- mps/example/scheme/r4rs.scm | 4 +- mps/example/scheme/scheme-malloc.c | 81 ++++++++++++++++++++++++++++-- mps/example/scheme/test-r5rs.scm | 4 +- 3 files changed, 83 insertions(+), 6 deletions(-) diff --git a/mps/example/scheme/r4rs.scm b/mps/example/scheme/r4rs.scm index 0b62af1c342..4a1759a0a9c 100644 --- a/mps/example/scheme/r4rs.scm +++ b/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)) diff --git a/mps/example/scheme/scheme-malloc.c b/mps/example/scheme/scheme-malloc.c index 788fc9e47ac..ac406444436 100644 --- a/mps/example/scheme/scheme-malloc.c +++ b/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 (( ) ...) ( ...) ...) */ - +/* entry_do -- (do (( ) ...) ( ...) ...) + * 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 expressions + are evaluated (in some unspecified order), the s are + bound to fresh locations, the results of the expressions + are stored in the bindings of the 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 ; */ + 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 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 expressions are evaluated in some unspecified + order, the s are bound to fresh locations, the + results of the s are stored in the bindings of the + 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 evaluates to a true value, then the s + are evaluated from left to right and the value of the last + is returned as the value of the do expression. + If no 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; } diff --git a/mps/example/scheme/test-r5rs.scm b/mps/example/scheme/test-r5rs.scm index 6402d166755..1a1fe853fed 100644 --- a/mps/example/scheme/test-r5rs.scm +++ b/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