Add define-symbolic-type macro.

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))
 
 
 ;;;