diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 170 |
1 files changed, 85 insertions, 85 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index 278ca63..6af69eb 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -114,14 +114,6 @@ ((fragment) (memq name '(gl-frag-depth gl-sample-mask))))) -(define (difference a b) - (match a - (() b) - ((x . rest) - (if (memq x b) - (difference rest (delq x b)) - (cons x (difference rest b)))))) - ;;; ;;; Lexical environments @@ -326,7 +318,7 @@ (define (expand:outputs names exps stage env) `(outputs ,@(map (lambda (name exp) - (list (if (built-in-output? name (current-shader-stage)) + (list (if (built-in-output? name stage) name (lookup name env)) (expand exp stage env))) @@ -808,6 +800,71 @@ (function-type? obj) (overload-type? obj))) +(define (apply-substitution-to-type type from to) + (cond + ((or (primitive-type? type) + (outputs-type? type)) + type) + ((type-variable? type) + (if (equal? type from) to type)) + ((function-type? type) + (function-type + (map (lambda (param-type) + (apply-substitution-to-type param-type from to)) + (function-type-parameters type)) + (map (lambda (return-type) + (apply-substitution-to-type return-type from to)) + (function-type-returns type)))) + ((overload-type? type) + (apply overload-type + (map (lambda (type) + (apply-substitution-to-type type from to)) + (overload-type-ref type)))) + (else (error "invalid type" type)))) + +(define (apply-substitutions-to-type type subs) + (env-fold (lambda (from to type*) + (apply-substitution-to-type type* from to)) + type + subs)) + +(define (apply-substitutions-to-types types subs) + (map (lambda (type) + (apply-substitutions-to-type type subs)) + types)) + +;; Typed expressions: +(define (texp types exp) + `(t ,types ,exp)) + +(define (texp? obj) + (match obj + (('t _ _) #t) + (_ #f))) + +(define (texp-types texp) + (match texp + (('t types _) types))) + +(define (texp-exp texp) + (match texp + (('t _ exp) exp))) + +(define (single-type texp) + (match (texp-types texp) + ((type) type) + (_ (error "expected only 1 type" texp)))) + + +;;; +;;; Type annotation +;;; + +;; Convert untyped Seagull expressions into typed expressions with +;; type variables representing all unknown types. This annotated +;; version of a Seagull program can then be passed to the type +;; inference algorithm to solve for all of the variables. + (define add/sub-type (list (overload-type (function-type (list int-type int-type) @@ -977,82 +1034,6 @@ `((texture-2d ,(function-type (list sampler-2d-type vec2-type) (list vec4-type)))))))) -(define (occurs? a b) - (cond - ((and (type-variable? a) (type-variable? b)) - (eq? a b)) - ((and (type-variable? a) (function-type? b)) - (or (occurs? a (function-type-parameters b)) - (occurs? a (function-type-returns b)))) - ((and (type? a) (list? b)) - (any (lambda (b*) (occurs? a b*)) b)) - (else #f))) - -(define (apply-substitution-to-type type from to) - (cond - ((or (primitive-type? type) - (outputs-type? type)) - type) - ((type-variable? type) - (if (equal? type from) to type)) - ((function-type? type) - (function-type - (map (lambda (param-type) - (apply-substitution-to-type param-type from to)) - (function-type-parameters type)) - (map (lambda (return-type) - (apply-substitution-to-type return-type from to)) - (function-type-returns type)))) - ((overload-type? type) - (apply overload-type - (map (lambda (type) - (apply-substitution-to-type type from to)) - (overload-type-ref type)))) - (else (error "invalid type" type)))) - -(define (apply-substitutions-to-type type subs) - (env-fold (lambda (from to type*) - (apply-substitution-to-type type* from to)) - type - subs)) - -(define (apply-substitutions-to-types types subs) - (map (lambda (type) - (apply-substitutions-to-type type subs)) - types)) - -;; Typed expressions: -(define (texp types exp) - `(t ,types ,exp)) - -(define (texp? obj) - (match obj - (('t _ _) #t) - (_ #f))) - -(define (texp-types texp) - (match texp - (('t types _) types))) - -(define (texp-exp texp) - (match texp - (('t _ exp) exp))) - -(define (single-type texp) - (match (texp-types texp) - ((type) type) - (_ (error "expected only 1 type" texp)))) - - -;;; -;;; Type annotation -;;; - -;; Convert untyped Seagull expressions into typed expressions with -;; type variables representing all unknown types. This annotated -;; version of a Seagull program can then be passed to the type -;; inference algorithm to solve for all of the variables. - (define (lookup-type name env) (let ((type (lookup name env))) (if (for-all-type? type) @@ -1075,6 +1056,14 @@ (for-all-type-quantifiers type))) (else (error "unknown type" type)))) +(define (difference a b) + (match a + (() b) + ((x . rest) + (if (memq x b) + (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)))) @@ -1235,6 +1224,17 @@ ;; thanks to type inference the user doesn't have to specify any types ;; expect for shader inputs, outputs, and uniforms. +(define (occurs? a b) + (cond + ((and (type-variable? a) (type-variable? b)) + (eq? a b)) + ((and (type-variable? a) (function-type? b)) + (or (occurs? a (function-type-parameters b)) + (occurs? a (function-type-returns b)))) + ((and (type? a) (list? b)) + (any (lambda (b*) (occurs? a b*)) b)) + (else #f))) + (define (compose-substitutions a b) (define b* (map (match-lambda |