while in terms of syntax-case

* module/ice-9/boot-9.scm (while): Reimplement in terms of syntax-case.
  Prompt inlining is coming later.

* test-suite/tests/syntax.test ("while"): Update the expected syntax
  errors.

module/ice-9/boot-9.scm

@@ -2842,28 +2842,46 @@ module '(ice-9 q) '(make-q q-length))}."
 ;;; with `continue' and `break'.
 ;;;
 
-;; The inner `do' loop avoids re-establishing a catch every iteration,
+;; The inliner will remove the prompts at compile-time if it finds that
-;; that's only necessary if continue is actually used.  A new key is
+;; `continue' or `break' are not used.
-;; generated every time, so break and continue apply to their originating
-;; `while' even when recursing.
 ;;
-;; FIXME: This macro is unintentionally unhygienic with respect to let,
+(define-syntax while
-;; make-symbol, do, throw, catch, lambda, and not.
+  (lambda (x)
-;;
+    (syntax-case x ()
-(define-macro (while cond . body)
+      ((while cond body ...)
-  (let ((keyvar (make-symbol "while-keyvar")))
+       #`(let ((break-tag (make-prompt-tag "break"))
-    `(let ((,keyvar (make-symbol "while-key")))
+               (continue-tag (make-prompt-tag "continue")))
-       (do ()
+           (call-with-prompt
-           ((catch ,keyvar
+            break-tag
             (lambda ()
-                     (let ((break (lambda () (throw ,keyvar #t)))
+              (define-syntax #,(datum->syntax #'while 'break)
-                           (continue (lambda () (throw ,keyvar #f))))
+                (lambda (x)
-                       (do ()
+                  (syntax-case x ()
-                           ((not ,cond))
+                    ((_)
-                         ,@body)
+                     #'(abort-to-prompt break-tag))
-                       #t))
+                    ((_ . args)
-                   (lambda (key arg)
+                     (syntax-violation 'break "too many arguments" x))
-                     arg)))))))
+                    (_
+                     #'(lambda ()
+                         (abort-to-prompt break-tag))))))
+              (let lp ()
+                (call-with-prompt
+                 continue-tag
+                 (lambda () 
+                   (define-syntax #,(datum->syntax #'while 'continue)
+                     (lambda (x)
+                       (syntax-case x ()
+                         ((_)
+                          #'(abort-to-prompt continue-tag))
+                         ((_ . args)
+                          (syntax-violation 'continue "too many arguments" x))
+                         (_
+                          #'(lambda args 
+                              (apply abort-to-prompt continue-tag args))))))
+                   (do () ((not cond)) body ...))
+                 (lambda (k) (lp)))))
+            (lambda (k)
+              #t)))))))
 
 
 

test-suite/tests/syntax.test

@@ -1,6 +1,6 @@
 ;;;; syntax.test --- test suite for Guile's syntactic forms    -*- scheme -*-
 ;;;;
-;;;; Copyright (C) 2001,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2001,2003,2004, 2005, 2006, 2009, 2010 Free Software Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -75,6 +75,9 @@
 (define exception:bad-cond-clause
   (cons 'syntax-error "Bad cond clause"))
 
+(define exception:too-many-args
+  (cons 'syntax-error "too many arguments"))
+
 
 (with-test-prefix "expressions"
 
@@ -832,7 +835,7 @@
 	     #t))))
   
 
-  (pass-if-exception "too few args" exception:wrong-num-args
+  (pass-if-exception "too few args" exception:generic-syncase-error
     (eval '(while) (interaction-environment)))
   
   (with-test-prefix "empty body"
@@ -872,7 +875,7 @@
   
   (with-test-prefix "break"
     
-    (pass-if-exception "too many args" exception:wrong-num-args
+    (pass-if-exception "too many args" exception:too-many-args
       (eval '(while #t
                (break 1))
             (interaction-environment)))
@@ -945,7 +948,7 @@
   
   (with-test-prefix "continue"
     
-    (pass-if-exception "too many args" exception:wrong-num-args
+    (pass-if-exception "too many args" exception:too-many-args
       (eval '(while #t
                (continue 1))
             (interaction-environment)))