From 8338ee8756f1382f43d2a73d4c72ec866d524081 Mon Sep 17 00:00:00 2001
From: Sam Tobin-Hochstadt <samth@racket-lang.org>
Date: Thu, 19 Jun 2008 16:55:06 -0400
Subject: [PATCH]  * Add constraints when matching t1...a to t2...b  * Do
 inference when you have (apply f ... xs), f and xs are dotted,    and on
 different bounds.  * Add fold-right to extra-procs and its type to base-env

original commit: b9e1676a55ab3f8d454a58aa290a0dcb0ecce414
---
 collects/typed-scheme/private/base-env.ss    | 2 ++
 collects/typed-scheme/private/extra-procs.ss | 9 +++++++--
 collects/typed-scheme/private/type-utils.ss  | 3 ++-
 3 files changed, 11 insertions(+), 3 deletions(-)

diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss
index 115f7838..07999859 100644
--- a/collects/typed-scheme/private/base-env.ss
+++ b/collects/typed-scheme/private/base-env.ss
@@ -130,6 +130,8 @@
                                    ((-lst b) b) . ->... . -Void))]
      [fold-left (-polydots (c a b) ((list ((list c a) (b b) . ->... . c) c (-lst a))
                                     ((-lst b) b) . ->... . c))]
+     [fold-right (-polydots (c a b) ((list ((list c a) (b b) . ->... . c) c (-lst a))
+                                     ((-lst b) b) . ->... . c))]
      [foldl
       (-poly (a b c)
              (cl-> [((a b . -> . b) b (make-lst a)) b]
diff --git a/collects/typed-scheme/private/extra-procs.ss b/collects/typed-scheme/private/extra-procs.ss
index e2c6b97b..7c793ccf 100644
--- a/collects/typed-scheme/private/extra-procs.ss
+++ b/collects/typed-scheme/private/extra-procs.ss
@@ -6,5 +6,10 @@
     (error "Assertion failed - value was #f"))
   v)
 
-
-
+(define (fold-right f c as . bss)
+  (if (or (null? as)
+          (ormap null? bss))
+      c
+      (apply f
+             (apply fold-right f c (cdr as) (map cdr bss))
+             (car as) (map car bss))))
\ No newline at end of file
diff --git a/collects/typed-scheme/private/type-utils.ss b/collects/typed-scheme/private/type-utils.ss
index 5987266e..4022514d 100644
--- a/collects/typed-scheme/private/type-utils.ss
+++ b/collects/typed-scheme/private/type-utils.ss
@@ -12,6 +12,7 @@
 (provide fv fv/list
          substitute
          substitute-dots
+         substitute-dotted
          subst-all
          subst 
          ret
@@ -76,7 +77,7 @@
       target))
 
 ;; implements sd from the formalism
-;; substitute-dotted : Type Name Type Name -> Type
+;; substitute-dotted : Type Name Name Type -> Type
 (define (substitute-dotted image image-bound name target)
   (define (sb t) (substitute-dotted image image-bound name t))
   (if (hash-ref (free-vars* target) name #f)