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