make each invocation of `while' throw to different keys

* ice-9/boot-9.scm (while): Further fixes to while, brought out by the
  test suite. Also updated documentary comments.

diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index d3da2c6..1f46db4 100644 (file)
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -2723,32 +2723,25 @@ module '(ice-9 q) '(make-q q-length))}."
 ;; The inner `do' loop avoids re-establishing a catch every iteration,
 ;; that's only necessary if continue is actually used.  A new key is
 ;; generated every time, so break and continue apply to their originating
-;; `while' even when recursing.  `while-helper' is an easy way to keep the
-;; `key' binding away from the cond and body code.
+;; `while' even when recursing.
 ;;
-;; FIXME: This is supposed to have an `unquote' on the `do' the same used
-;; for lambda and not, so as to protect against any user rebinding of that
-;; symbol, but unfortunately an unquote breaks with ice-9 syncase, eg.
-;;
-;;     (use-modules (ice-9 syncase))
-;;     (while #f)
-;;     => ERROR: invalid syntax ()
-;;
-;; This is probably a bug in syncase.
+;; FIXME: This macro is unintentionally unhygienic with respect to let,
+;; make-symbol, do, throw, catch, lambda, and not.
 ;;
 (define-macro (while cond . body)
-  (let ((key (make-symbol "while-key")))
-    `(do ()
-         ((catch ',key
-                 (lambda ()
-                   (let ((break (lambda () (throw ',key #t)))
-                         (continue (lambda () (throw ',key #f))))
-                     (do ()
-                         ((not ,cond))
-                       ,@body)
-                     #t))
-                 (lambda (key arg)
-                   arg))))))
+  (let ((keyvar (make-symbol "while-keyvar")))
+    `(let ((,keyvar (make-symbol "while-key")))
+       (do ()
+           ((catch ,keyvar
+                   (lambda ()
+                     (let ((break (lambda () (throw ,keyvar #t)))
+                           (continue (lambda () (throw ,keyvar #f))))
+                       (do ()
+                           ((not ,cond))
+                         ,@body)
+                       #t))
+                   (lambda (key arg)
+                     arg)))))))
 
 
 \f