From 103125ae1ac6cd038d38e63bb0884f7c12e88650 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 15 Apr 2003 17:51:07 +0000
Subject: [PATCH] added any to ->*

original commit: 7c400f407ce0d90256cbf936816aa2067e961377
---
 collects/mzlib/contract.ss | 47 ++++++++++++++++++++++++++++++++++++--
 1 file changed, 45 insertions(+), 2 deletions(-)

diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss
index 2b5539f..ae1fd11 100644
--- a/collects/mzlib/contract.ss
+++ b/collects/mzlib/contract.ss
@@ -1186,7 +1186,7 @@
     
     ;; ->*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
     (define (->*/h stx)
-      (syntax-case stx ()
+      (syntax-case stx (any)
         [(_ (dom ...) (rng ...))
          (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
                        [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
@@ -1359,7 +1359,50 @@
                        (cond
                          [(= len rng-length) (vector rng-x ...)]
                          [else #f]))
-                   #f)))))]))
+                   #f)))))]
+	[(_ (dom ...) rest any)
+         (with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(arg-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [(dom-length dom-index ...) (generate-indicies (syntax (dom ...)))]
+                       [(dom-ant-x ...) (generate-temporaries (syntax (dom ...)))]
+                       [dom-rest-x (car (generate-temporaries (list (syntax rest))))]
+                       [arg-rest-x (car (generate-temporaries (list (syntax rest))))]
+                       
+                       [arity (length (syntax->list (syntax (dom ...))))])
+           (values
+            (lambda (body)
+              (with-syntax ([body body])
+                (syntax
+                 (let ([dom-x dom] ...
+                       [dom-rest-x rest])
+                   (unless (-contract? dom-x)
+                     (error '->* "expected contract for domain position, given: ~e" dom-x)) ...
+                   (unless (-contract? dom-rest-x)
+                     (error '->* "expected contract for rest position, given: ~e" dom-rest-x))
+                   body))))
+            (lambda (stx)
+              (with-syntax ([(val check-rev-contract check-same-contract failure) stx])
+                (syntax
+                 (unless (procedure? val)
+                   (raise-contract-error
+                    src-info
+                    pos-blame
+                    neg-blame
+                    "expected a procedure that accepts ~a arguments, given: ~e"
+                    dom-length
+                    val)))))
+            (lambda (stx)
+              (with-syntax ([(val pos-blame neg-blame src-info) stx])
+                (syntax
+                 ((arg-x ... . arg-rest-x)
+                  (apply
+		   val
+		   (check-contract dom-x arg-x neg-blame pos-blame src-info)
+		   ...
+		   (check-contract dom-rest-x arg-rest-x neg-blame pos-blame src-info))))))
+	    (lambda (body stx) (syntax (lambda x (error 'impl-contract "unimplemented for ->* (any case)"))))
+	    (syntax (x (error 'impl-contract "unimplemented for ->* (any case)")))
+	    (syntax (lambda x (error 'impl-contract "unimplemented for ->* (any case)")))))]))
     
     ;; ->d/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
     (define (->d/h stx)