summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/seagull.scm188
1 files changed, 67 insertions, 121 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 9dc6cb1..dd1cbc6 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -197,41 +197,39 @@
;;; Types
;;;
-;; Primitive types:
-(define (primitive-type name)
- `(primitive ,name))
-
-(define (primitive-type? obj)
- (match obj
- (('primitive _) #t)
- (_ #f)))
-
-(define (primitive-type-name type)
- (match type
- (('primitive name) name)))
-
-;; Outputs type:
-(define type:outputs '(outputs))
-
-(define (outputs-type? obj)
- (equal? obj type:outputs))
-
-;; Struct type:
-(define (struct-type name fields)
- `(struct ,name ,fields))
-
-(define (struct-type? obj)
- (match obj
- (('struct _ _) #t)
- (_ #f)))
-
-(define (struct-type-name type)
- (match type
- (('struct name _) name)))
-
-(define (struct-type-fields type)
- (match type
- (('struct _ fields) fields)))
+;; Record types are not used here because these type objects appear in
+;; the compiled intermediate form of Seagull, which is generated at
+;; compile-time. Record types cannot be interned so simple tagged
+;; lists are used instead.
+(define-syntax-rule (define-symbolic-type name
+ constructor predicate (field getter) ...)
+ (begin
+ (define (constructor field ...)
+ (list 'name field ...))
+ (define (predicate obj)
+ (match obj
+ (('name field ...) #t)
+ (_ #f)))
+ (define (getter obj)
+ (match obj
+ (('name field ...)
+ field)))
+ ...))
+
+(define-symbolic-type primitive
+ primitive-type
+ primitive-type?
+ (name primitive-type-name))
+
+(define-symbolic-type outputs
+ outputs-type
+ outputs-type?)
+
+(define-symbolic-type struct
+ struct-type
+ struct-type?
+ (name struct-type-name)
+ (fields struct-type-fields))
(define (struct-type-ref type field)
(assq-ref (struct-type-fields type) field))
@@ -239,24 +237,12 @@
(define-syntax-rule (define-struct-type (var-name name) (types names) ...)
(define var-name (struct-type 'name (list (cons 'names types) ...))))
-;; Array type:
-(define (array-type type length)
- `(array ,type ,length))
-
-(define (array-type? type)
- (match type
- (('array _ _) #t)
- (_ #f)))
-
-(define (array-type-ref type)
- (match type
- (('array type _) type)))
+(define-symbolic-type array
+ array-type
+ array-type?
+ (type array-type-ref)
+ (length array-type-length))
-(define (array-type-length type)
- (match type
- (('array _ n) n)))
-
-;; Type variables:
(define unique-variable-type-counter (make-parameter 0))
(define (unique-variable-type-number)
@@ -268,8 +254,10 @@
(string->symbol
(format #f "T~a" (unique-variable-type-number))))
-(define (variable-type name)
- `(tvar ,name))
+(define-symbolic-type tvar
+ variable-type
+ variable-type?
+ (name variable-type-name))
(define (fresh-variable-type)
(variable-type (unique-variable-type-name)))
@@ -277,77 +265,34 @@
(define (fresh-variable-types-for-list lst)
(map (lambda (_x) (fresh-variable-type)) lst))
-(define (variable-type? obj)
- (match obj
- (('tvar _) #t)
- (_ #f)))
-
-;; Function types:
-(define (function-type parameters returns)
- `(-> ,parameters ,returns))
-
-(define (function-type? obj)
- (match obj
- (('-> _ _) #t)
- (_ #f)))
-
-(define (function-type-parameters type)
- (match type
- (('-> params _) params)))
+(define-symbolic-type ->
+ function-type
+ function-type?
+ (parameters function-type-parameters)
+ (returns function-type-returns))
-(define (function-type-returns type)
- (match type
- (('-> _ returns) returns)))
-
-;; Function case types:
-;;
;; For GLSL primitives that support multiple arities.
-(define (function-case-type cases)
- `(case-> ,cases))
-
-(define (function-case-type? obj)
- (match obj
- (('case-> _) #t)
- (_ #f)))
+(define-symbolic-type case->
+ function-case-type
+ function-case-type?
+ (cases function-case-type-cases))
(define (function-case-type-ref type arity)
- (match type
- (('case-> cases)
- (assv-ref cases arity))))
-
-;; Type schemes:
-(define (type-scheme quantifiers type)
- `(type-scheme ,quantifiers ,type))
-
-(define (type-scheme? obj)
- (match obj
- (('type-scheme _ _) #t)
- (_ #f)))
-
-(define (type-scheme-quantifiers type)
- (match type
- (('type-scheme q _) q)))
-
-(define (type-scheme-ref type)
- (match type
- (('type-scheme _ t) t)))
-
-;; Qualified types:
-(define (qualified-type type pred)
- `(qualified ,type ,pred))
-
-(define (qualified-type? obj)
- (match obj
- (('qualified _ _) #t)
- (_ #f)))
-
-(define (qualified-type-ref type)
- (match type
- (('qualified type _) type)))
-
-(define (qualified-type-predicate type)
- (match type
- (('qualified _ pred) pred)))
+ (assv-ref (function-case-type-cases type) arity))
+
+;; For parametric polymorphism.
+(define-symbolic-type for-all
+ type-scheme
+ type-scheme?
+ (quantifiers type-scheme-quantifiers)
+ (type type-scheme-ref))
+
+;; For ad-hoc polymorphism.
+(define-symbolic-type qualified
+ qualified-type
+ qualified-type?
+ (type qualified-type-ref)
+ (predicate qualified-type-predicate))
(define (type? obj)
(or (primitive-type? obj)
@@ -646,6 +591,7 @@
(define type:mat3 (primitive-type 'mat3))
(define type:mat4 (primitive-type 'mat4))
(define type:sampler-2d (primitive-type 'sampler2D))
+(define type:outputs (outputs-type))
;;;