Partial multi-value return support.

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