From e519a29adcc1cfec368eaab2e186960caf039d47 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Mon, 10 Jun 2002 20:39:55 +0000
Subject: [PATCH] ..

original commit: 024a1a90247703e7eb35512274fd31c0cae673ff
---
 collects/framework/specs.ss | 25 ++++++++++++++++---------
 1 file changed, 16 insertions(+), 9 deletions(-)

diff --git a/collects/framework/specs.ss b/collects/framework/specs.ss
index ee5f2ba..7bc170a 100644
--- a/collects/framework/specs.ss
+++ b/collects/framework/specs.ss
@@ -7,6 +7,7 @@
            ->d*
            case->
 	   opt->
+           opt->*
            (rename -contract? contract?)
            provide/contract)
 
@@ -575,30 +576,36 @@
   (define-syntax (opt-> stx)
     (syntax-case stx ()
       [(_ (reqs ...) (opts ...) res)
-       (let* ([res-v (generate-temporaries (list (syntax res)))]
+       (syntax (opt->* (reqs ...) (opts ...) (res)))]))
+  
+  (define-syntax (opt->* stx)
+    (syntax-case stx ()
+      [(_ (reqs ...) (opts ...) (ress ...))
+       (let* ([res-vs (generate-temporaries (syntax->list (syntax (ress ...))))]
 	      [req-vs (generate-temporaries (syntax->list (syntax (reqs ...))))]
 	      [opt-vs (generate-temporaries (syntax->list (syntax (opts ...))))]
 	      [cases
 	       (reverse
 		(let loop ([opt-vs (reverse opt-vs)])
 		  (cond
-		    [(null? opt-vs) (list (append req-vs res-v))]
-		    [else (cons (append req-vs (reverse opt-vs) res-v)
+		    [(null? opt-vs) (list req-vs)]
+		    [else (cons (append req-vs (reverse opt-vs))
 				(loop (cdr opt-vs)))])))])
-	 (with-syntax ([(res-v) res-v]
-		       [(req-vs ...) req-vs]
+	 (with-syntax ([((double-res-vs ...) ...) (map (lambda (x) res-vs) cases)]
+		       [(res-vs ...) res-vs]
+                       [(req-vs ...) req-vs]
 		       [(opt-vs ...) opt-vs]
-		       [((cases ...) ...) cases])
+		       [((case-doms ...) ...) cases])
 	   (syntax
-	    (let ([res-v res]
+	    (let ([res-vs ress] ...
 		  [req-vs reqs] ...
 		  [opt-vs opts] ...)
-	      (case-> (-> cases ...) ...)))))]))
+	      (case-> (->* (case-doms ...) (double-res-vs ...)) ...)))))]))
 
   (define -contract?
     (let ([contract?
            (lambda (val)
-             (or (contract? val)  ;; refers to struct
+             (or (contract? val)  ;; refers to struct predicate
                  (and (procedure? val)
                       (procedure-arity-includes? val 1))))])
       contract?))