summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/seagull.scm96
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))))