summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--chickadee/graphics/seagull.scm128
1 files changed, 122 insertions, 6 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index c53e034..7c78ab2 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -170,6 +170,9 @@
(string->symbol
(format #f "V~a" (unique-identifier-number))))
+(define (unique-identifiers-for-list lst)
+ (map (lambda (_x) (unique-identifier)) lst))
+
(define (alpha-convert names)
(define names* (map (lambda (_name) (unique-identifier)) names))
(fold extend-env (empty-env) names names*))
@@ -415,6 +418,10 @@
(('primitive _) #t)
(_ #f)))
+(define (primitive-type-name type)
+ (match type
+ (('primitive name) name)))
+
(define int-type (primitive-type 'int))
(define float-type (primitive-type 'float))
(define bool-type (primitive-type 'bool))
@@ -731,8 +738,7 @@
(annotate:top-level bindings body env))))
(define (annotate-exp* exp)
- (parameterize ((unique-type-variable-counter 0))
- (annotate-exp exp (top-level-type-env))))
+ (annotate-exp exp (top-level-type-env)))
;;;
@@ -898,6 +904,8 @@
(resolve type env)
var)))
+;; TODO: If there are still quantified type variables, scan the entire
+;; program for calls to the function and build an intersection type.
(define (resolve:for-all type env)
(let ((quantifiers (filter type-variable?
(resolve (for-all-type-quantifiers type) env)))
@@ -926,6 +934,108 @@
;; Transform typed expressions into a string of GLSL code.
+(define (emit:number n port)
+ (display (number->string n) port))
+
+(define (emit:boolean b port)
+ (display (if b "true" "false") port))
+
+(define (emit:type type port)
+ (display (primitive-type-name type) port))
+
+(define (emit:binary-operator op a b port)
+ (display "(" port)
+ (emit-glsl a port)
+ (format port " ~a " op)
+ (emit-glsl b port)
+ (display ")" port))
+
+(define (emit:declaration type name exp port)
+ (emit:type type port)
+ (display " " port)
+ (display name port)
+ (when exp
+ (begin
+ (display " = " port)
+ (emit-glsl exp port)))
+ (display ";\n" port))
+
+(define (emit:assignment name exp port)
+ (display "(" port)
+ (display name port)
+ (display " = " port)
+ (emit-glsl exp port)
+ (display ")" port))
+
+(define (emit:function name type params body port)
+ (define param-types (function-type-parameters type))
+ (define return-types (function-type-returns type))
+ (define outputs (unique-identifiers-for-list return-types))
+ (format port "void ~a(" name)
+ (let loop ((params (append (zip (make-list (length params) 'in)
+ param-types
+ params)
+ (zip (make-list (length return-types) 'out)
+ return-types
+ outputs)))
+ (first? #t))
+ (match params
+ (() #t)
+ (((qualifier type name) . rest)
+ (unless first?
+ (display ", " port))
+ (format port "~a " qualifier)
+ (emit:type type port)
+ (format port " ~a" name)
+ (loop rest #f))))
+ (display ") {\n" port)
+ ;; TODO: Multiple return values.
+ (emit:assignment (first outputs) body port)
+ (display ";\n}\n" port))
+
+(define (emit:if predicate consequent alternate port)
+ (display "(" port)
+ (emit-glsl predicate port)
+ (display " ? " port)
+ (emit-glsl consequent port)
+ (display " : " port)
+ (emit-glsl alternate port)
+ (display ")" port))
+
+(define (emit:let type bindings body port)
+ (define temp (unique-identifier))
+ (define type* (first (function-type-returns type)))
+ (emit:declaration type* temp #f port)
+ (for-each (match-lambda
+ ((name (and exp ('t (type) _)))
+ (emit:declaration type name exp port)))
+ bindings)
+ (emit:assignment temp body port)
+ (display ";\n" port))
+
+(define (emit:top-level bindings body port)
+ (for-each (match-lambda
+ ((name ('t (type) ('lambda params body)))
+ (emit:function name type params body port)))
+ bindings)
+ (emit-glsl body port))
+
+(define (emit-glsl exp port)
+ (match exp
+ (('t _ (? number? n))
+ (emit:number n port))
+ (('t _ (? boolean? b))
+ (emit:boolean b port))
+ (('t _ ('var var _))
+ (display var port))
+ (('t _ ('primcall ('t _ (and (or '+ '- '* '/) op)) a b))
+ (emit:binary-operator op a b port))
+ (('t _ ('if predicate consequent alternate))
+ (emit:if predicate consequent alternate port))
+ (('t (type) ('let bindings body))
+ (emit:let type bindings body port))
+ (('t _ ('top-level (bindings ...) body))
+ (emit:top-level bindings body port))))
;;;
@@ -939,14 +1049,20 @@
(for-each (lambda (x) (format #t "~a\n" x)) lst))
;; Substitutions aren't being generated correctly.
-(define (compile-seagull exp)
- (parameterize ((unique-identifier-counter 0))
+(define* (compile-seagull exp #:optional (port (current-output-port)))
+ (parameterize ((unique-identifier-counter 0)
+ (unique-type-variable-counter 0))
(let* ((expanded (pk 'expanded (expand exp (top-level-env))))
(hoisted (pk 'hoisted (hoist-functions* expanded)))
(texp (pk 'annotated (annotate-exp* hoisted)))
(constraints (pk 'constraints (constrain-texp texp)))
- (substitutions (pk 'substitutions (unify-constraints constraints))))
+ (substitutions (pk 'substitutions (unify-constraints constraints)))
+ (resolved (pk 'resolved (resolve texp substitutions))))
+ (display "*** BEGIN GLSL OUTPUT ***\n" port)
+ (emit-glsl resolved port)
+ (newline port)
+ (display "*** END GLSL OUTPUT ***\n" port)
(list 'annotated texp
'constraints constraints
'substitutions substitutions
- 'resolved (resolve texp substitutions)))))
+ 'resolved resolved))))