From 519b3ec07265d65900707830ae439afa01137481 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sat, 7 Jan 2023 22:03:53 -0500
Subject: call-with-values

---
 infer2.scm | 41 ++++++++++++++++++++++++++++++-----------
 1 file changed, 30 insertions(+), 11 deletions(-)

diff --git a/infer2.scm b/infer2.scm
index 03a8d32..015f897 100644
--- a/infer2.scm
+++ b/infer2.scm
@@ -251,11 +251,6 @@
                   ,(annotate-exp consequent env)
                   ,(annotate-exp alternate env))))
 
-(define-matcher (annotate:values ('values vals ...) env)
-  (define vals* (map (lambda (val) (annotate-exp val env)) vals))
-  (define val-types (map single-type vals*))
-  (make-texp val-types `(values ,@vals*)))
-
 (define-matcher (annotate:let ('let (((? symbol? vars) vals) ...) body) env)
   (define vals* (map (lambda (val) (annotate-exp val env)) vals))
   (define val-types (map (lambda (val)
@@ -293,6 +288,17 @@
              (cons operator*
                    args*)))
 
+(define-matcher (annotate:values ('values vals ...) env)
+  (define vals* (map (lambda (val) (annotate-exp val env)) vals))
+  (define val-types (map single-type vals*))
+  (make-texp val-types `(values ,@vals*)))
+
+(define-matcher (annotate:call-with-values ('call-with-values producer consumer)
+                                           env)
+  (define producer* (annotate-exp producer env))
+  (define consumer* (annotate-exp consumer env))
+  (make-texp (texp-types consumer*)
+             `(call-with-values ,producer* ,consumer*)))
 
 (define annotate-exp
   (compose-matchers annotate:bool
@@ -300,10 +306,11 @@
                     annotate:float
                     annotate:var
                     annotate:if
-                    annotate:values
                     annotate:let
                     annotate:begin
                     annotate:lambda
+                    annotate:values
+                    annotate:call-with-values
                     annotate:call))
 
 (define (annotate-exp* exp)
@@ -339,10 +346,6 @@
           (program-constraints consequent)
           (program-constraints alternate)))
 
-(define-matcher (constrain:values ((? type? types) ...)
-                                  ('values (? texp? vals) ...))
-  (append-map program-constraints vals))
-
 (define-matcher (constrain:let ((? type? types) ...)
                                ('let (((? symbol? vars) (? texp? vals)) ...)
                                  (? texp? body)))
@@ -379,13 +382,29 @@
         (append (program-constraints operator)
                 (append-map program-constraints operands))))
 
+(define-matcher (constrain:values ((? type? types) ...)
+                                  ('values (? texp? vals) ...))
+  (append-map program-constraints vals))
+
+(define-matcher (constrain:call-with-values ((? procedure-type? type))
+                                            ('call-with-values
+                                                (? texp? producer)
+                                              (? texp? consumer)))
+  (define params (procedure-type-parameter-types type))
+  (cons (pk 'constrain-call-with-values
+            (constrain (texp-types producer)
+                       (list (make-procedure-type '() params))))
+        (append  (program-constraints producer)
+                 (program-constraints consumer))))
+
 (define %program-constraints
   (compose-matchers constrain:if
-                    constrain:values
                     constrain:let
                     constrain:begin
                     constrain:for-all-lambda
                     constrain:lambda
+                    constrain:values
+                    constrain:call-with-values
                     constrain:call
                     constrain:other))
 
-- 
cgit v1.2.3