From 3b431c6ff2ef7869ac3720e4046fa94a53782ff3 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 4 Aug 2010 10:42:19 -0500
Subject: [PATCH] ->i now evaluates the arguments in the proper order

---
 collects/racket/contract/private/arr-i.rkt | 31 ++++++++++++----
 collects/racket/contract/scratch.rkt       | 41 +++++++++++++++-------
 2 files changed, 54 insertions(+), 18 deletions(-)

diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt
index 439a51dc9a..c07e5f3fce 100644
--- a/collects/racket/contract/private/arr-i.rkt
+++ b/collects/racket/contract/private/arr-i.rkt
@@ -75,13 +75,32 @@
    #:first-order (λ (ctc) (λ (x) #f)) ;; WRONG
    #:stronger (λ (this that) #f))) ;; WRONG
 
-;; find-ordering : (listof arg) -> (listof (cons number arg))
+;; find-ordering : (listof arg) -> (values (listof arg) (listof number)) 
+;; sorts the arguments according to the dependency order.
+;; returns them in the reverse of that order, ie expressions that need
+;; to be evaluted first come later in the list.
 (define-for-syntax (find-ordering args)
-  (values (reverse args)
-          (reverse
-           (for/list ([arg (in-list args)]
-                      [i (in-naturals)])
-             i))))
+  
+  (define (comes-before? x y)
+    (cond
+      [(depends-on? (car x) (car y)) #t]
+      [(depends-on? (car y) (car x)) #f]
+      [else (< (cdr x) (cdr y))]))
+  
+  (define (depends-on? arg1 arg2)
+    (and (arg-vars arg2)
+         (ormap (λ (x) (free-identifier=? x (arg-var arg1)))
+                (arg-vars arg2))))
+  
+  (let* ([numbered (for/list ([arg (in-list args)]
+                              [i (in-naturals)])
+                     (cons arg i))]
+         [sorted
+          (sort 
+           numbered
+           (λ (x y) (not (comes-before? x y))))])
+    (values (map car sorted)
+            (map cdr sorted))))
 
 ;; args/vars->arglist : (listof arg?) (vectorof identifier?) -> syntax
 ;; (vector-length vars) = (length args)
diff --git a/collects/racket/contract/scratch.rkt b/collects/racket/contract/scratch.rkt
index c804d58f31..cff4b3c3cc 100644
--- a/collects/racket/contract/scratch.rkt
+++ b/collects/racket/contract/scratch.rkt
@@ -2,23 +2,32 @@
 (require racket/contract
          racket/pretty)
 
-#;
 (pretty-print
  (syntax->datum (expand-once
-                 #'(->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))))
-
+                 #'(->i ([x number?]
+                         [y (x z) (between/c x z)]
+                         [z number?])
+                        any))))
 
 #;
-((contract (->i ([x number?] [y (x) (<=/c x)]) any)
-           (λ (x y) (+ x y))
+(pretty-print
+ (syntax->datum (expand
+                 #'(->i ([x number?]
+                         [y (x z) (between/c x z)]
+                         [z number?])
+                        any))))
+
+
+((contract (->i ([x number?]
+                 [y (x z) (between/c x z)]
+                 [z number?])
+                any)
+           (λ (x y z) (+ x y z))
            'pos 'neg)
- -1 -1)
-
+ 1 2 3)
+;; => 6
 
+#|
 ;; timing tests:
 
 (define f1
@@ -48,7 +57,7 @@
 
 'f1 (tme f1)
 'f2 (tme f2)
-
+|#
 
 #|
 test cases:
@@ -158,5 +167,13 @@ test cases:
      [y (x) number?])
 ;; => no syntax error
 
+((contract (->i ([x number?]
+                 [y (x z) (between/c x z)]
+                 [z number?])
+                any)
+           (λ (x y z) (+ x y z))
+           'pos 'neg)
+ 1 2 3)
+;; => 6
 
 |#