Overload resolution that almost works.

1 files changed, 76 insertions, 20 deletions

diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 4cb1a21..91562c7 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -967,9 +967,20 @@
   (texp (apply-substitutions-to-types (texp-types t) subs)
         (texp-exp t)))
 
+(define (apply-substitutions-to-exp exp subs)
+  (match exp
+    ((? type?)
+     (apply-substitutions-to-type exp subs))
+    ((exps ...)
+     (map (lambda (exp)
+            (apply-substitutions-to-exp exp subs))
+          exps))
+    (_ exp)))
+
 (define (apply-substitution-to-predicate pred from to)
   (match pred
     (#t #t)
+    (#f #f)
     (('= a b)
      `(= ,(apply-substitution-to-type a from to)
          ,(apply-substitution-to-type b from to)))
@@ -979,15 +990,12 @@
                   preds)))
     (('or preds ...)
      `(or ,@(map (lambda (pred)
-                    (apply-substitution-to-predicate pred from to))
+                   (apply-substitution-to-predicate pred from to))
                  preds)))
     (('list preds ...)
      `(list ,@(map (lambda (pred)
                      (apply-substitution-to-predicate pred from to))
                    preds)))
-    (('when test consequent)
-     `(when ,(apply-substitution-to-predicate test from to)
-        ,(apply-substitution-to-predicate consequent from to)))
     (('substitute a b)
      `(substitute ,(apply-substitution-to-type a from to)
                   ,(apply-substitution-to-type b from to)))))
@@ -1451,17 +1459,6 @@
            (define-values (rest-pred subs*)
              (eval-predicate (apply predicate:list rest)))
            (values (predicate:list pred* rest-pred) subs*))))))
-    (('when test consequent)
-     (define-values (new-test subs)
-       (eval-predicate test))
-     (match new-test
-       (#t
-        (let ()
-          (define-values (new-consequent subs*)
-            (eval-predicate consequent))
-          (values new-consequent (compose-substitutions subs subs*))))
-       (#f (values #f '()))
-       (_ (values `(when ,new-test ,consequent) '()))))
     ;; Substitution always succeeds and returns a substitution to be
     ;; carried forward in the inference process.
     (('substitute a b)
@@ -1541,9 +1538,6 @@
      (append-map (lambda (pred)
                    (free-variables-in-predicate pred))
                  preds))
-    (('when test consequent)
-     (append (free-variables-in-predicate test)
-             (free-variables-in-predicate consequent)))
     (('substitute a b)
      (append (free-variables-in-type a)
              (free-variables-in-type b)))))
@@ -1952,6 +1946,66 @@
 
 
 ;;;
+;;; Overloaded functions
+;;;
+
+;; Replace quantified functions ('for-all' expressions) with a series
+;; of non-quantified function type specifications, one for each unique
+;; type of call in the program.
+
+(define (possible-substitutions pred)
+  (match pred
+    (#t '())
+    (('substitute from to)
+     (list (list (cons from to))))
+    (('= a b)
+     (list (list (cons a b))))
+    (('or preds ...)
+     (concatenate (map possible-substitutions preds)))
+    (((or 'and 'list) preds ...)
+     (let loop ((in (map possible-substitutions preds)))
+       (match in
+         (() '())
+         ((options . rest)
+          (define rest-options (loop rest))
+          (append-map (lambda (a)
+                        (if (null? rest-options)
+                            (list a)
+                            (map (lambda (b)
+                                   (compose-substitutions a b))
+                                 rest-options)))
+                      options)))))))
+
+(define (possible-signatures type)
+  (define type* (for-all-type-ref type))
+  (map (lambda (subs)
+         (apply-substitutions-to-type type* subs))
+       (possible-substitutions (for-all-type-predicate type))))
+
+(define (resolve-overloads program)
+  (match program
+    (('t types ('top-level bindings body))
+     (define bindings*
+       (let loop ((bindings bindings))
+         (match bindings
+           (() '())
+           ((('function name ('t ((? for-all-type? type)) func)) . rest)
+            (define func-type (for-all-type-ref type))
+            (append (map (lambda (subs)
+                           (define type*
+                             (apply-substitutions-to-type func-type subs))
+                           (define func*
+                             (apply-substitutions-to-exp func subs))
+                           `(function ,name (t (,type*) ,func*)))
+                         (possible-substitutions (for-all-type-predicate type)))
+                    (loop rest)))
+           ((binding . rest)
+            (cons binding (loop rest))))))
+     `(t ,types (top-level ,bindings* ,body)))
+    (_ (error "expected top-level form" program))))
+
+
+;;;
 ;;; GLSL emission
 ;;;
 
@@ -2214,6 +2268,8 @@
     (let* ((expanded (expand exp stage (top-level-env)))
            (propagated (propagate-constants expanded (empty-env)))
            (hoisted (hoist-functions* propagated))
-           (inferred (infer-types hoisted stage)))
+           (inferred (infer-types hoisted stage))
+           (resolved (resolve-overloads inferred)))
       (pretty-print inferred)
-      (emit-glsl inferred version port))))
+      (pretty-print resolved)
+      (emit-glsl resolved version port))))