From f9b20d3789036d7a14a68bcafcc88cb40039ee33 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Tue, 22 Jul 2014 22:42:26 -0500
Subject: [PATCH] fix bug in ->i

---
 .../tests/racket/contract/arrow-i.rkt         |   8 ++
 .../racket/contract/private/arr-i.rkt         | 104 ++++++++++++++----
 2 files changed, 93 insertions(+), 19 deletions(-)

diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-i.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-i.rkt
index 92a0a9fda4..7cb60c55de 100644
--- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-i.rkt
+++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/arrow-i.rkt
@@ -876,6 +876,14 @@
                'neg))
    'qq)
   
+  (test/spec-passed/result
+   '->i53
+   '((contract (->i ([x (z) (if (equal? z 1) any/c none/c)] [y any/c] [z any/c]) any)
+               (λ (x y z) x)
+               'pos 'neg)
+     3 2 1)
+   3)
+  
   (test/pos-blame
    '->i-arity1
    '(contract (->i ([x number?]) () any) (λ () 1) 'pos 'neg))
diff --git a/racket/collects/racket/contract/private/arr-i.rkt b/racket/collects/racket/contract/private/arr-i.rkt
index bd26f34e23..c16d57531e 100644
--- a/racket/collects/racket/contract/private/arr-i.rkt
+++ b/racket/collects/racket/contract/private/arr-i.rkt
@@ -306,29 +306,95 @@
 ;; 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.
-;; BAD: this seem wrong, as it doesn't consider transitive dependencies
 (define-for-syntax (find-ordering args)
   
-  (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))]))
+  #|
+
+This uses a variation of the topological sorting algorithm
+from Wikipedia attributed to Kahn (1962). It doesn't run in
+linear time since it uses a linear scan at each step to find
+the 'least' argument contract to pick. (Picking the least arg
+ensures that args that are independent of each other are still
+evaluted left-to-right.)
+
+  |#
   
-  (define (depends-on? arg1 arg2)
-    (and (arg/res-vars arg2)
-         (ormap (λ (x) (free-identifier=? x (arg/res-var arg1)))
-                (arg/res-vars arg2))))
+  (define numbers (make-hasheq)) ;; this uses eq?, but it could use a number in the 'arg' struct
+  (define id->arg/res (make-free-identifier-mapping))
+  (for ([arg (in-list args)]
+        [i (in-naturals)])
+    (hash-set! numbers arg i)
+    (free-identifier-mapping-put! id->arg/res (arg/res-var arg) arg))
   
-  (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))))
+  (define comes-before (make-free-identifier-mapping))
+  (define comes-after (make-free-identifier-mapping))
+  (for ([arg (in-list args)])
+    (free-identifier-mapping-put! comes-before (arg/res-var arg) '())
+    (free-identifier-mapping-put! comes-after (arg/res-var arg) '()))
+  (for ([arg (in-list args)])
+    (when (arg/res-vars arg)
+      (define arg-id (arg/res-var arg))
+      (for ([dep-id (in-list (arg/res-vars arg))])
+        (define dep (free-identifier-mapping-get id->arg/res dep-id (λ () #f)))
+        (when dep
+          ;; dep = #f should happen only when we're handling the result
+          ;; contracts and dep-id is one of the argument contracts.
+          ;; in that case, we can just ignore the edge since we know
+          ;; it will be bound already
+          (free-identifier-mapping-put!
+           comes-before
+           arg-id
+           (cons dep (free-identifier-mapping-get comes-before arg-id)))
+          (free-identifier-mapping-put!
+           comes-after
+           dep-id
+           (cons arg (free-identifier-mapping-get comes-after dep-id)))))))
+  
+  (define sorted '())
+  (define no-incoming-edges
+    (for/list ([arg (in-list args)]
+               #:when (null? (free-identifier-mapping-get comes-before (arg/res-var arg))))
+      arg))
+  
+  (define (pick-next-node)
+    (define least-node
+      (let loop ([nodes (cdr no-incoming-edges)]
+                 [least-node (car no-incoming-edges)])
+        (cond
+          [(null? nodes) least-node]
+          [else
+           (define node (car nodes))
+           (cond
+             [(< (hash-ref numbers node) (hash-ref numbers least-node))
+              (loop (cdr nodes) node)]
+             [else
+              (loop (cdr nodes) least-node)])])))
+    (set! no-incoming-edges (remove least-node no-incoming-edges))
+    least-node)
+  
+  (define (remove-edge from to)
+    (free-identifier-mapping-put!
+     comes-before
+     (arg/res-var to)
+     (remove from (free-identifier-mapping-get comes-before (arg/res-var to))))
+    (free-identifier-mapping-put!
+     comes-after
+     (arg/res-var from)
+     (remove to (free-identifier-mapping-get comes-after (arg/res-var from)))))
+  
+  (let loop ()
+    (unless (null? no-incoming-edges)
+      (define n (pick-next-node))
+      (set! sorted (cons n sorted))
+      (for ([m (in-list (free-identifier-mapping-get comes-after (arg/res-var n)))])
+        (remove-edge n m)
+        (when (null? (free-identifier-mapping-get comes-before (arg/res-var m)))
+          (set! no-incoming-edges (cons m no-incoming-edges))))
+      (loop)))
+  
+  (values sorted
+          (for/list ([arg (in-list sorted)])
+            (hash-ref numbers arg))))
 
 ;; args/vars->arglist : (listof arg?) (vectorof identifier?) -> syntax
 ;; (vector-length vars) = (length args)