Re: while break and continue

[Kevin Ryde <user42@zip.com.au>]

[-- Attachment #1: Type: text/plain, Size: 1594 bytes --]

I applied this

        * boot-9.scm (while): Rewrite, continue as a proper escape, break
        doesn't take a return value, break and continue procs new for each
        while form allowing use in nested whiles, don't depend on bindings in
        expansion environment.

        * tests/syntax.test (while): New tests.

        * scheme-control.texi (while do): Update `while' for code rewrite, in
        particular describe break and continue.


 - syntax: while cond body ...
     Run a loop executing the BODY forms while COND is true.  COND is
     tested at the start of each iteration, so if it's `#f' the first
     time then BODY is not executed at all.  The return value is
     unspecified.

     Within `while', two extra bindings are provided, they can be used
     from both COND and BODY.

      - Scheme Procedure: break
          Break out of the `while' form.

      - Scheme Procedure: continue
          Abandon the current iteration, go back to the start and test
          COND again, etc.

     Each `while' form gets its own `break' and `continue' procedures,
     operating on that `while'.  This means when loops are nested the
     outer `break' can be used to escape all the way out.  For example,

          (while (test1)
            (let ((outer-break break))
              (while (test2)
                (if (something)
                  (outer-break #f))
                ...)))

     Note that each `break' and `continue' procedure can only be used
     within the dynamic extent of its `while'.  Outside the `while'
     their behaviour is unspecified.




[-- Attachment #2: boot-9.scm.while.diff --]
[-- Type: text/plain, Size: 1252 bytes --]

--- boot-9.scm.~1.316.~	2003-05-30 08:40:07.000000000 +1000
+++ boot-9.scm	2003-08-14 07:38:41.000000000 +1000
@@ -2491,18 +2491,6 @@
         (loop (1- count) (cons count result)))))
 
 \f
-;;; {While}
-;;;
-;;; with `continue' and `break'.
-;;;
-
-(defmacro while (cond . body)
-  `(letrec ((continue (lambda () (or (not ,cond) (begin (begin ,@ body) (continue)))))
-	    (break (lambda val (apply throw 'break val))))
-     (catch 'break
-	    (lambda () (continue))
-	    (lambda v (cadr v)))))
-
 ;;; {collect}
 ;;;
 ;;; Similar to `begin' but returns a list of the results of all constituent
@@ -2560,6 +2548,26 @@
       (else
        (error "define-syntax-macro can only be used at the top level")))))
 
+;;; {While}
+;;;
+;;; with `continue' and `break'.
+;;;
+
+;; The inner `do' loop avoids re-establishing a catch every iteration,
+;; that's only necessary if continue is actually used.
+;;
+(define-macro (while cond . body)
+  (let ((key (make-symbol "while-key")))
+    `(,do ((break    ,(lambda () (throw key #t)))
+	   (continue ,(lambda () (throw key #f))))
+	 ((,catch (,quote ,key)
+		  (,lambda ()
+		    (,do ()
+			((,not ,cond))
+		      ,@body)
+		    #t)
+		  ,(lambda (key arg) arg))))))
+
 \f
 ;;; {Module System Macros}
 ;;;

[-- Attachment #3: syntax.test.while.diff --]
[-- Type: text/plain, Size: 3788 bytes --]

--- syntax.test.~1.10.~	2003-04-28 07:51:30.000000000 +1000
+++ syntax.test	2003-08-12 22:30:55.000000000 +1000
@@ -550,3 +550,171 @@
       exception:missing/extra-expr
       (eval '(quote a b)
 	    (interaction-environment)))))
+
+(with-test-prefix "while"
+  
+  (define (unreachable)
+    (error "unreachable code has been reached!"))
+  
+  ;; an environment with no bindings at all
+  (define empty-environment
+    (make-module 1))
+  
+  ;; Return a new procedure COND which when called (COND) will return #t the
+  ;; first N times, then #f, then any further call is an error.  N=0 is
+  ;; allowed, in which case #f is returned by the first call.
+  (define (make-iterations-cond n)
+    (lambda ()
+      (cond ((not n)
+	     (error "oops, condition re-tested after giving false"))
+	    ((= 0 n)
+	     (set! n #f)
+	     #f)
+	    (else
+	     (set! n (1- n))
+	     #t))))
+  
+
+  (pass-if-exception "too few args" exception:wrong-num-args
+    (while))
+  
+  (with-test-prefix "empty body"
+    (do ((n 0 (1+ n)))
+	((> n 5))
+      (pass-if n
+	(let ((cond (make-iterations-cond n)))
+	  (while (cond)))
+	#t)))
+  
+  (pass-if "initially false"
+    (while #f
+      (unreachable))
+    #t)
+  
+  (with-test-prefix "in empty environment"
+    
+    (pass-if "empty body"
+      (eval `(,while #f)
+	    empty-environment)
+      #t)
+    
+    (pass-if "initially false"
+      (eval `(,while #f
+	       #f)
+	    empty-environment)
+      #t)
+    
+    (pass-if "iterating"
+      (let ((cond (make-iterations-cond 3)))
+	(eval `(,while (,cond)
+		 123 456)
+	      empty-environment))
+      #t))
+  
+  (with-test-prefix "iterations"
+    (do ((n 0 (1+ n)))
+	((> n 5))
+      (pass-if n
+	(let ((cond (make-iterations-cond n))
+	      (i    0))
+	  (while (cond)
+	    (set! i (1+ i)))
+	  (= i n)))))
+  
+  (with-test-prefix "break"
+    
+    (pass-if-exception "too many args" exception:wrong-num-args
+      (while #t
+	(break 1)))
+    
+    (with-test-prefix "from cond"
+      (pass-if "first"
+	(while (begin
+		 (break)
+		 (unreachable))
+	  (unreachable))
+	#t)
+      
+      (do ((n 0 (1+ n)))
+	  ((> n 5))
+	(pass-if n
+	  (let ((cond (make-iterations-cond n))
+		(i    0))
+	    (while (if (cond)
+		       #t
+		       (begin
+			 (break)
+			 (unreachable)))
+	      (set! i (1+ i)))
+	    (= i n)))))
+    
+    (with-test-prefix "from body"
+      (pass-if "first"
+	(while #t
+	  (break)
+	  (unreachable))
+	#t)
+      
+      (do ((n 0 (1+ n)))
+	  ((> n 5))
+	(pass-if n
+	  (let ((cond (make-iterations-cond n))
+		(i    0))
+	    (while #t
+	      (if (not (cond))
+		  (begin
+		    (break)
+		    (unreachable)))
+	      (set! i (1+ i)))
+	    (= i n)))))
+    
+    (pass-if "from nested"
+      (while #t
+	(let ((outer-break break))
+	  (while #t
+	    (outer-break)
+	    (unreachable)))
+	(unreachable))
+      #t))
+  
+  (with-test-prefix "continue"
+    
+    (pass-if-exception "too many args" exception:wrong-num-args
+      (while #t
+	(continue 1)))
+    
+    (with-test-prefix "from cond"
+      (do ((n 0 (1+ n)))
+	  ((> n 5))
+	(pass-if n
+	  (let ((cond (make-iterations-cond n))
+		(i    0))
+	    (while (if (cond)
+		       (begin
+			 (set! i (1+ i))
+			 (continue)
+			 (unreachable))
+		       #f)
+	      (unreachable))
+	    (= i n)))))
+    
+    (with-test-prefix "from body"
+      (do ((n 0 (1+ n)))
+	  ((> n 5))
+	(pass-if n
+	  (let ((cond (make-iterations-cond n))
+		(i    0))
+	    (while (cond)
+	      (set! i (1+ i))
+	      (continue)
+	      (unreachable))
+	    (= i n)))))
+    
+    (pass-if "from nested"
+      (let ((cond (make-iterations-cond 3)))
+	(while (cond)
+	  (let ((outer-continue continue))
+	    (while #t
+	      (outer-continue)
+	      (unreachable)))))
+      #t)))

[-- Attachment #4: Type: text/plain, Size: 142 bytes --]

_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-devel