From d2894e7a8e6133e83ad6b69f108cc615f2aba110 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 4 Aug 2010 08:08:55 -0500
Subject: [PATCH] added in a use of Shu-yu's opt/c to see if it helps (which it
 does for complex contracts)

---
 collects/racket/contract/private/arr-i.rkt |  5 +-
 collects/racket/contract/scratch.rkt       | 56 ++++++++--------------
 2 files changed, 22 insertions(+), 39 deletions(-)

diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt
index 71a4e01b0e..439a51dc9a 100644
--- a/collects/racket/contract/private/arr-i.rkt
+++ b/collects/racket/contract/private/arr-i.rkt
@@ -3,6 +3,7 @@
 (require "arrow.rkt"
          "prop.rkt"
          "guts.rkt"
+         "opt.rkt"
          unstable/location
          (for-syntax racket/base
                      racket/stxparam-exptime
@@ -279,7 +280,7 @@
            ;; all of the non-dependent argument contracts
            (list arg-exp-xs ...)
            ;; all of the dependent argument contracts
-           (list #,@(filter values (map (λ (arg) (and (arg-vars arg) #`(λ #,(arg-vars arg) #,(arg-ctc arg))))
+           (list #,@(filter values (map (λ (arg) (and (arg-vars arg) #`(λ #,(arg-vars arg) (opt/c #,(arg-ctc arg)))))
                                         (istx-args an-istx))))
            ;; then the non-dependent argument contracts that are themselves dependend on
            (list #,@(filter values
@@ -295,7 +296,7 @@
                                                 (istx-ress an-istx))))
                  #''())
            #,(if (istx-ress an-istx) 
-                 #`(list #,@(filter values (map (λ (arg) (and (res-vars arg) #`(λ #,(res-vars arg) #,(res-ctc arg))))
+                 #`(list #,@(filter values (map (λ (arg) (and (res-vars arg) #`(λ #,(res-vars arg) (opt/c #,(res-ctc arg)))))
                                                 (istx-ress an-istx))))
                  #''())
            ;; WRONG! this needs to be a subset of the previuos^2 (and to generate a let to share appropriately)
diff --git a/collects/racket/contract/scratch.rkt b/collects/racket/contract/scratch.rkt
index 89d0edd4dd..c804d58f31 100644
--- a/collects/racket/contract/scratch.rkt
+++ b/collects/racket/contract/scratch.rkt
@@ -5,44 +5,30 @@
 #;
 (pretty-print
  (syntax->datum (expand-once
-                 #'(->i ([f number?] 
-                         [y (f) (<=/c f)])
-                        any))))
+                 #'(->i ([x number?] [y (x) (<=/c x)]) any))))
+
+(pretty-print
+ (syntax->datum (expand
+                 #'(->i ([x number?] [y number?] [z (x y) (if (<= x y) (<=/c x) (<=/c y))]) any))))
+
 
 #;
-((contract (->i ([f number?] 
-                 [y (f) (<=/c f)])
-                any)
+((contract (->i ([x number?] [y (x) (<=/c x)]) any)
            (λ (x y) (+ x y))
            'pos 'neg)
  -1 -1)
 
 
-(define f0 (λ (x y) (+ x y)))
+;; timing tests:
 
 (define f1
-  (contract (-> number? (<=/c 0) any)
-            (λ (x y) (+ x y))
+  (contract (-> number? number? (or/c (<=/c 1) (<=/c 2)) any)
+            (λ (x y z) (+ x y z))
             'pos 'neg))
 
 (define f2
-  (contract (->i ([x number?] [y (<=/c 0)]) any)
-            (λ (x y) (+ x y))
-            'pos 'neg))
-
-(define f3
-  (contract (->i ([x number?] [y (x) (<=/c x)]) any)
-            (λ (x y) (+ x y))
-            'pos 'neg))
-
-(define f4
-  (contract (->d ([x number?] [y (<=/c 0)]) any)
-            (λ (x y) (+ x y))
-            'pos 'neg))
-
-(define f5
-  (contract (->d ([x number?] [y (<=/c x)]) any)
-            (λ (x y) (+ x y))
+  (contract (->i ([x number?] [y number?] [z (x y) (or/c (<=/c x) (<=/c y))]) any)
+            (λ (x y z) (+ x y z))
             'pos 'neg))
 
 
@@ -50,23 +36,19 @@
   (time
    (let loop ([n 100000])
      (unless (zero? n)
-       (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) 
-       (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) 
-       (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) 
-       (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) 
-       (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) 
-       (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) (f -1 -1) 
+       (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) 
+       (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) 
+       (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) 
+       (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) 
+       (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) 
+       (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) (f -1 -1 -1) 
        (loop (- n 1))))))
 
 'ignore: (tme f1)
 
-'f0 (tme f0)
-
 'f1 (tme f1)
 'f2 (tme f2)
-'f3 (tme f3)
-'f4 (tme f4)
-'f5 (tme f5)
+
 
 #|
 test cases: