From 1cf3559d0ca11f1a21313ed9738a5e726d374710 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Mon, 24 Oct 2005 11:24:41 +0000
Subject: [PATCH] #:allow-anything can be used with any rest-like, simply
 treats a last imbalanced keyword as the beginning of the body

svn: r1141
---
 collects/mzlib/kw.ss          | 30 ++++++++++++++----------------
 collects/tests/mzscheme/kw.ss |  5 +----
 2 files changed, 15 insertions(+), 20 deletions(-)

diff --git a/collects/mzlib/kw.ss b/collects/mzlib/kw.ss
index 8d298e53bc..d567718859 100644
--- a/collects/mzlib/kw.ss
+++ b/collects/mzlib/kw.ss
@@ -311,12 +311,20 @@
                                next-loop
                                (error* 'name "unknown keyword: ~e"
                                        (car body*))))])
-            (if (not allow-anything?) ; normal code
+            (if (and allow-anything?
+                     (not body) (not rest-keys) (not all-keys) (not other-keys))
+              ;; allowing anything and don't need special rests, so no loop
+              #'expr
+              ;; normal code
               #`(let loop loop-vars
-                  (if (and (pair? body*) (keyword? (car body*)))
-                    (if (pair? (cdr body*))
-                      next-loop
-                      (error* 'name "keyword list not balanced: ~e" rest*))
+                  (if (and (pair? body*) (keyword? (car body*))
+                           #,@(if allow-anything? #'((pair? (cdr body*))) '()))
+                    #,(if allow-anything? ; already checker pair? above
+                        #'next-loop
+                        #'(if (pair? (cdr body*))
+                            next-loop
+                            (error* 'name "keyword list not balanced: ~e"
+                                    rest*)))
                     #,(if allow-body?
                         (if (and body (not (identifier? body)))
                           (with-syntax ([name (string->symbol
@@ -332,17 +340,7 @@
                         #'(if (null? body*)
                             expr
                             (error* 'name "expecting a ~s keyword got: ~e"
-                                    'keywords (car body*))))))
-              ;; allowing anything: can't use rest-like except for rest
-              (let ([bad (cond [body       `(,body       #:body)]
-                               [rest-keys  `(,rest-keys  #:rest-keys)]
-                               [all-keys   `(,all-keys   #:all-keys)]
-                               [other-keys `(,other-keys #:other-keys)]
-                               [else #f])])
-                (if bad
-                  (serror (car bad) "cannot use #:allow-anything with ~a"
-                          (cadr bad))
-                  #'expr)))))))
+                                    'keywords (car body*)))))))))))
     ;; ------------------------------------------------------------------------
     ;; generates the part of the body that deals with rest-related stuff
     (define (make-keys-body expr)
diff --git a/collects/tests/mzscheme/kw.ss b/collects/tests/mzscheme/kw.ss
index 8a1b618d39..ce1f7daf51 100644
--- a/collects/tests/mzscheme/kw.ss
+++ b/collects/tests/mzscheme/kw.ss
@@ -279,6 +279,7 @@
        (f #:x 1 #:x 2 #:y) => 1))
   (t '(#:x 1 #:z) <= ((lambda/kw (#:key x #:allow-anything #:rest r) r)
                       #:x 1 #:z))
+  (t '(#:z) <= ((lambda/kw (#:key x #:allow-anything #:body r) r) #:x 1 #:z))
 
   ;; make sure that internal definitions work
   (let ([f (lambda/kw (#:key x) (define xx x) xx)])
@@ -303,10 +304,6 @@
      :st-err: <= (lambda/kw (x #:rest r #:allow-anything #:forbid-anything) 1)
      :st-err: <= (lambda/kw (#:key a #:forbid-other-keys #:allow-anything) 1)
      :st-err: <= (lambda/kw (#:key a #:forbid-duplicate-keys #:allow-anything) 1)
-     :st-err: <= (lambda/kw (#:key a #:body r #:allow-anything) 1)
-     :st-err: <= (lambda/kw (#:key a #:rest-keys r #:allow-anything) 1)
-     :st-err: <= (lambda/kw (#:key a #:all-keys r #:allow-anything) 1)
-     :st-err: <= (lambda/kw (#:key a #:other-keys r #:allow-anything) 1)
      :st-err: <= (lambda/kw (#:key a #:forbid-other-keys #:allow-anything) 1)
      :st-err: <= (lambda/kw (#:key a #:forbid-duplicate-keys #:allow-anything) 1)
      :st-err: <= (lambda/kw (#:key a #:forbid-body #:allow-anything) 1)