diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 96 |
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)))) |