From 70d2fa327d8218662292fb824edfc40a799b3976 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Mon, 27 Feb 2006 04:42:27 +0000
Subject: [PATCH] When both optionals and keywords are used, the first keyword
 marks the end of the optionals.

svn: r2322
---
 collects/mzlib/kw.ss          | 22 +++++++++++++++++++++-
 collects/tests/mzscheme/kw.ss | 28 ++++++++++++++++++++++++----
 2 files changed, 45 insertions(+), 5 deletions(-)

diff --git a/collects/mzlib/kw.ss b/collects/mzlib/kw.ss
index 0de07dfe4f..1a0480abd2 100644
--- a/collects/mzlib/kw.ss
+++ b/collects/mzlib/kw.ss
@@ -384,10 +384,30 @@
                     [body (make-keys-body expr)])
         (syntax/loc stx (lambda vars body)))]
      ;; both opts and keys => combine the above two
+     ;; (the problem with this is that things that follow the required
+     ;; arguments are always taken as optionals, even if they're keywords, so
+     ;; the following piece of code is used.)
+     #;
      [else
       (let ([clauses (make-opt-clauses (make-keys-body expr) rest*)])
         (with-syntax ([name name] [clauses clauses])
-          (syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))]))
+          (syntax/loc stx (letrec ([name (case-lambda . clauses)]) name))))]
+     ;; both opts and keys => pop optionals as long as they're not keywords
+     [else
+      (with-syntax
+          ([rest rest*]
+           [vars (append! vars rest*)]
+           [body (make-keys-body expr)]
+           [((optvar optexpr) ...)
+            (apply append
+                   (map (lambda (opt)
+                          (with-syntax ([(ovar odef) opt] [rest rest*])
+                            (list #'[otmp (if (null? rest)
+                                            #t (keyword? (car rest)))]
+                                  #'[ovar (if otmp odef (car rest))]
+                                  #'[rest (if otmp rest (cdr rest))])))
+                        opts))])
+        (syntax/loc stx (lambda vars (let* ([optvar optexpr] ...) body))))]))
   (syntax-case stx ()
     [(_ formals expr0 expr ...)
      (generate-body #'formals #'(let () expr0 expr ...))]))
diff --git a/collects/tests/mzscheme/kw.ss b/collects/tests/mzscheme/kw.ss
index 2e60656633..fe8993ddf8 100644
--- a/collects/tests/mzscheme/kw.ss
+++ b/collects/tests/mzscheme/kw.ss
@@ -227,14 +227,34 @@
 
   ;; optionals and keys
   (let ([f (lambda/kw (#:optional a b #:key c d) (list a b c d))])
+    ;; the parts that are commented out are relying on the old (CL-like)
+    ;; behavior of always treating the first arguments as optionals.  Now a
+    ;; keyword marks the end of the optionals.
     (t '(#f #f #f #f)    <= (f)
        '(1 #f #f #f)     <= (f 1)
        '(1 2 #f #f)      <= (f 1 2)
-       '(#:c #:d #f #f)  <= (f #:c #:d)
-       '(#:c 1 #f #f)    <= (f #:c 1)
+       ;; '(#:c #:d #f #f)  <= (f #:c #:d)
+       ;; '(#:c 1 #f #f)    <= (f #:c 1)
        '(1 2 #:d #f)     <= (f 1 2 #:c #:d)
-       '(#:c #:d #:d #f) <= (f #:c #:d #:c #:d)
-       '(#:c 1 #:d #f)   <= (f #:c 1 #:c #:d)))
+       ;; '(#:c #:d #:d #f) <= (f #:c #:d #:c #:d)
+       ;; '(#:c 1 #:d #f)   <= (f #:c 1 #:c #:d)
+       ;; Test new behavior on the commented expressions that are valid
+       '(#f #f #:d #f)   <= (f #:c #:d)
+       '(#f #f 1 #f)     <= (f #:c 1)
+       ;; Now test the new behavior
+       '(#f #f #f 2)     <= (f #:d 2)
+       '(1 #f #f 2)      <= (f 1 #:d 2)
+       '(1 2 #f 2)       <= (f 1 2 #:d 2)
+       '(1 #f #f 2)      <= (f 1 #f #:d 2)))
+  (let ([f (lambda/kw (x #:optional a b #:key c d) (list x a b c d))])
+    ;; also test that the required argument is still working fine
+    (t '(0 #f #f #f 2)   <= (f 0 #:d 2)
+       '(0 1 #f #f 2)    <= (f 0 1 #:d 2)
+       '(0 1 2 #f 2)     <= (f 0 1 2 #:d 2)
+       '(0 1 #f #f 2)    <= (f 0 1 #f #:d 2)
+       '(#:x 1 #f #f 2)  <= (f #:x 1 #f #:d 2)
+       ;; and test errors
+       :rt-err:          <= (f 0 #:c 2 #:c 3)))
 
   ;; multi-level arg lists with #:body specs
   (let ([f (lambda/kw (#:key x y #:body (z)) (list x y z))])