diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 88 |
1 files changed, 44 insertions, 44 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index fdd1487..d5515be 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -52,10 +52,11 @@ ;; GLSL code. ;; TODO: +;; - Array types ;; - Loops ;; - Shader stage linking -;; - Transform for-all functions into overloads -;; - User functions that use overloaded functions need to be overloaded themselves +;; - Input/uniform mapping for invoking shaders from Scheme +;; - Scheme shader type -> GLSL struct translation ;;; @@ -798,9 +799,10 @@ ;; Walk the expression tree of a type annotated program and solve for ;; all of the type variables using a variant of the Hindley-Milner -;; type inference algorithm. GLSL is a statically typed language, but -;; thanks to type inference the user doesn't have to specify any types -;; expect for shader inputs, outputs, and uniforms. +;; type inference algorithm extended to handle qualified types (types +;; with predicates.) GLSL is a statically typed language, but thanks +;; to type inference the user doesn't have to specify any types expect +;; for shader inputs, outputs, and uniforms. ;; Primitive types: (define (primitive-type name) @@ -816,12 +818,10 @@ (('primitive name) name))) ;; Outputs type: -(define outputs-type '(outputs)) +(define type:outputs '(outputs)) (define (outputs-type? obj) - (match obj - (('outputs) #t) - (_ #f))) + (eq? obj type:outputs)) ;; Struct type: (define (struct-type name members) @@ -889,22 +889,22 @@ (match type (('-> _ returns) returns))) -;; For all types: -(define (for-all-type quantifiers type) - `(for-all ,quantifiers ,type)) +;; Type schemes: +(define (type-scheme quantifiers type) + `(type-scheme ,quantifiers ,type)) -(define (for-all-type? obj) +(define (type-scheme? obj) (match obj - (('for-all _ _) #t) + (('type-scheme _ _) #t) (_ #f))) -(define (for-all-type-quantifiers type) +(define (type-scheme-quantifiers type) (match type - (('for-all q _) q))) + (('type-scheme q _) q))) -(define (for-all-type-ref type) +(define (type-scheme-ref type) (match type - (('for-all _ t) t))) + (('type-scheme _ t) t))) ;; Qualified types: (define (qualified-type type pred) @@ -946,7 +946,7 @@ (map (lambda (return-type) (apply-substitution-to-type return-type from to)) (function-type-returns type)))) - ((for-all-type? type) + ((type-scheme? type) type) (else (error "invalid type" type)))) @@ -1056,7 +1056,7 @@ (define (lookup-type name env) (let ((type (lookup name env))) - (if (for-all-type? type) + (if (type-scheme? type) (instantiate type) type))) @@ -1349,10 +1349,10 @@ (delete-duplicates (append-map free-variables-in-type (function-type-returns type)))))) - ((for-all-type? type) + ((type-scheme? type) (fold delete - (free-variables-in-type (for-all-type-ref type)) - (for-all-type-quantifiers type))) + (free-variables-in-type (type-scheme-ref type)) + (type-scheme-quantifiers type))) (else (error "unknown type" type)))) (define (difference a b) @@ -1363,9 +1363,9 @@ (difference rest (delq x b)) (cons x (difference rest b)))))) -(define (free-variables-in-for-all for-all) - (difference (for-all-type-quantifiers for-all) - (free-variables-in-type (for-all-type-ref for-all)))) +(define (free-variables-in-type-scheme type-scheme) + (difference (type-scheme-quantifiers type-scheme) + (free-variables-in-type (type-scheme-ref type-scheme)))) (define (free-variables-in-env env) (delete-duplicates @@ -1374,8 +1374,8 @@ ((variable-type? type) (cons (free-variables-in-type type) vars)) - ((for-all-type? type) - (cons (free-variables-in-for-all type) + ((type-scheme? type) + (cons (free-variables-in-type-scheme type) vars)) (else vars))) '() @@ -1416,16 +1416,16 @@ (free-variables-in-env env)) (() type) ((quantifiers ...) - (for-all-type quantifiers (qualified-type type pred)))) + (type-scheme quantifiers (qualified-type type pred)))) type)) -(define (instantiate for-all) +(define (instantiate type-scheme) (define subs (fold (lambda (var env) (extend-env var (fresh-variable-type) env)) (empty-env) - (for-all-type-quantifiers for-all))) - (define type (for-all-type-ref for-all)) + (type-scheme-quantifiers type-scheme))) + (define type (type-scheme-ref type-scheme)) (values (apply-substitutions-to-type (if (qualified-type? type) (qualified-type-ref type) @@ -1439,7 +1439,7 @@ (define (maybe-instantiate types) (define types+preds (map (lambda (type) - (if (for-all-type? type) + (if (type-scheme? type) (call-with-values (lambda () (instantiate type)) list) (list type #t))) types)) @@ -1723,7 +1723,7 @@ ;; Eval predicate. (define-values (pred combined-subs) (eval-predicate* exp-pred (compose-substitutions exp-subs unify-subs))) - (values (texp (list outputs-type) + (values (texp (list type:outputs) `(outputs ,@(map list names exps*))) combined-subs pred)) @@ -1852,7 +1852,7 @@ (let ((a (fresh-variable-type)) (b (fresh-variable-type)) (c (fresh-variable-type))) - (list (for-all-type + (list (type-scheme (list a b c) (qualified-type (function-type (list a b) (list c)) @@ -1865,7 +1865,7 @@ (define (top-level-type-env stage) (define type:+/- (let ((a (fresh-variable-type))) - (list (for-all-type + (list (type-scheme (list a) (qualified-type (function-type (list a a) (list a)) @@ -1912,7 +1912,7 @@ (list (function-type (list type:float) (list type:int)))) (define type:comparison (let ((a (fresh-variable-type))) - (list (for-all-type + (list (type-scheme (list a) (qualified-type (function-type (list a a) (list type:bool)) @@ -1932,7 +1932,7 @@ (list type:vec4)))) (define type:abs (let ((a (fresh-variable-type))) - (list (for-all-type + (list (type-scheme (list a) (qualified-type (function-type (list a) (list a)) @@ -1941,7 +1941,7 @@ (predicate:= a type:float))))))) (define type:sqrt (let ((a (fresh-variable-type))) - (list (for-all-type + (list (type-scheme (list a) (qualified-type (function-type (list a) (list a)) @@ -1950,7 +1950,7 @@ (predicate:= a type:float))))))) (define type:min/max (let ((a (fresh-variable-type))) - (list (for-all-type + (list (type-scheme (list a) (qualified-type (function-type (list a a) (list a)) @@ -1961,7 +1961,7 @@ (list (function-type (list type:float) (list type:float)))) (define type:clamp/mix (let ((a (fresh-variable-type))) - (list (for-all-type + (list (type-scheme (list a) (qualified-type (function-type (list a a) (list a)) @@ -2015,7 +2015,7 @@ ;;; Overloaded functions ;;; -;; Replace quantified functions ('for-all' expressions) with a series +;; Replace quantified functions ('type-scheme' expressions) with a series ;; of non-quantified function type specifications, one for each unique ;; type of call in the program. @@ -2084,8 +2084,8 @@ (let loop ((bindings bindings)) (match bindings (() '()) - ((('function name ('t ((? for-all-type? type)) func)) . rest) - (define qtype (for-all-type-ref type)) + ((('function name ('t ((? type-scheme? type)) func)) . rest) + (define qtype (type-scheme-ref type)) (define func-type (qualified-type-ref qtype)) (append (map (lambda (subs) (define type* |