diff options
| -rw-r--r-- | chickadee/graphics/seagull.scm | 44 |
1 files changed, 42 insertions, 2 deletions
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm index 023223b..143c5a0 100644 --- a/chickadee/graphics/seagull.scm +++ b/chickadee/graphics/seagull.scm @@ -229,6 +229,9 @@ (define params* (lookup-all params env*)) `(lambda ,params* ,(expand body env*))) +(define (expand:values exps env) + `(values ,@(expand:list exps env))) + ;; Arithmetic operators, in true Lisp fashion, can accept many ;; arguments. + and * accept 0 or more. - and / accept one or more. ;; The expansion pass transforms all such expressions into binary @@ -300,6 +303,8 @@ (expand:let names exps body env)) (('lambda ((? symbol? params) ...) body) (expand:lambda params body env)) + (('values exps ...) + (expand:values exps env)) ;; Macros: (('let* (bindings ...) body) (expand:let* bindings body env)) @@ -345,6 +350,11 @@ (define (propagate:lambda params body env) `(lambda ,params ,(propagate-constants body env))) +(define (propagate:values exps env) + `(values ,@(map (lambda (exp) + (propagate-constants exp env)) + exps))) + (define (propagate:let names exps body env) (define exps* (map (lambda (exp) @@ -413,6 +423,8 @@ (propagate:if predicate consequent alternate env)) (('lambda (params ...) body) (propagate:lambda params body env)) + (('values exps ...) + (propagate:values exps env)) (('let ((names exps) ...) body) (propagate:let names exps body env)) (('primcall (and (or '+ '- '* '/) op) x y) @@ -473,6 +485,8 @@ (check-free-variables body bound-vars* top-level-vars))) (('lambda (params ...) body) (check-free-variables body params top-level-vars)) + (('values exps ...) + (check-free-variables-in-list exps bound-vars top-level-vars)) ((or ('primcall _ args ...) ('call args ...)) (check-free-variables-in-list args bound-vars top-level-vars)))) @@ -513,6 +527,11 @@ (values `(var ,var #f) (extend-env var lambda* body-env))) +(define (hoist:values exps) + (define-values (exps* exp-env) + (hoist:list exps)) + (values `(values ,@exps*) exp-env)) + (define (hoist:primcall operator args) (define-values (args* args-env) (hoist:list args)) (values `(primcall ,operator ,@args*) @@ -533,6 +552,8 @@ (hoist:let names exps body)) (('lambda (params ...) body) (hoist:lambda params body)) + (('values exps ...) + (hoist:values exps)) (('primcall operator args ...) (hoist:primcall operator args)) (('call args ...) @@ -959,6 +980,11 @@ (texp (list (function-type param-types (texp-types body*))) `(lambda ,params ,body*))) +(define (annotate:values exps env) + (define exps* (annotate:list exps env)) + (texp (map single-type exps*) + `(values ,@exps*))) + (define (annotate:primitive-call operator args env) ;; The type signature of primitive functions can be looked up ;; directly in the environment. @@ -1006,6 +1032,8 @@ (annotate:let names exps body env)) (('lambda (params ...) body) (annotate:lambda params body env)) + (('values exps ...) + (annotate:values exps env)) (('primcall operator args ...) (annotate:primitive-call operator args env)) (('call operator args ...) @@ -1177,6 +1205,10 @@ (success (compose-substitutions sub0 sub1))))))) +(define (infer:values types exps subs success) + (pk 'infer:values exps) + (infer:list exps subs success)) + (define (infer:call types operator args subs success) (pk 'infer:call types operator args subs) (infer operator @@ -1253,6 +1285,8 @@ (infer:let types names exps body subs success)) (('t (type) ('lambda (params ...) body)) (infer:lambda type body subs success)) + (('t types ('values exps ...)) + (infer:values types exps subs success)) (('t types ('primcall operator args ...)) (infer:primcall types operator args subs success)) (('t types ('call operator args ...)) @@ -1414,6 +1448,11 @@ (display "}\n" port) if-temps) +(define (emit:values exps port level) + (append-map (lambda (exp) + (emit-glsl exp port level)) + exps)) + (define (emit:let types names exps body port level) (define binding-temps (map (lambda (exp) @@ -1476,6 +1515,8 @@ (list var)) (('t _ ('if predicate consequent alternate)) (emit:if predicate consequent alternate port level)) + (('t _ ('values exps ...)) + (emit:values exps port level)) (('t types ('let ((names exps) ...) body)) (emit:let types names exps body port level)) (('t (type) ('primcall ('t _ (? binary-operator? op)) a b)) @@ -1485,8 +1526,7 @@ (('t types ('call operator args ...)) (emit:call types operator args port level)) (('t _ ('top-level (bindings ...) body)) - (emit:top-level bindings body port level)) - (_ (error "woopsies")))) + (emit:top-level bindings body port level)))) ;;; |