summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2023-01-22 20:19:10 -0500
committerDavid Thompson <dthompson2@worcester.edu>2023-06-08 08:14:41 -0400
commitbd421255cb4ca4dec6312566e9bfa1456ef07bb3 (patch)
treea30f0483bbbd55dad3ceea559494171cbf450fdb
parente113d0c462811518e0b45159ec97503e878b329c (diff)
Partial multi-value return support.
-rw-r--r--chickadee/graphics/seagull.scm44
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))))
;;;