From c8d737284e631e626bc629469d77c2abb5d3847e Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sat, 7 Jan 2023 08:56:08 -0500
Subject: Add let and values forms.

---
 infer2.scm | 37 +++++++++++++++++++++++++++++++++++++
 1 file changed, 37 insertions(+)

(limited to 'infer2.scm')

diff --git a/infer2.scm b/infer2.scm
index 4097530..569792d 100644
--- a/infer2.scm
+++ b/infer2.scm
@@ -124,6 +124,29 @@
                   ,(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 (lambda (val)
+           (match (texp-types val)
+             ((type) type)
+             (types (error "expressions in values must return 1 value" val))))
+         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)
+                           (match (texp-types val)
+                             ((type) type)
+                             (_ (error "let bindings must return 1 value" val))))
+                         vals*))
+  (define env* (append (map cons vars val-types) env))
+  (define body* (annotate-exp body env*))
+  (pk 'body* body*)
+  (make-texp (texp-types body*)
+             `(let ,(map list vars vals*) ,body*)))
+
 (define-matcher (annotate:lambda ('lambda ((? symbol? args) ...) body) env)
   (define parameter-types (map (lambda (_name) (fresh-type-variable)) args))
   (define env* (append (map cons args parameter-types) env))
@@ -146,6 +169,8 @@
                     annotate:float
                     annotate:var
                     annotate:if
+                    annotate:values
+                    annotate:let
                     annotate:lambda
                     annotate:call))
 
@@ -183,6 +208,16 @@
           (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)))
+  (append (program-constraints body)
+          (append-map program-constraints vals)))
+
 (define-matcher (constrain:lambda ((? procedure-type? type))
                                   ('lambda ((? symbol? args) ...)
                                     (? texp? body)))
@@ -200,6 +235,8 @@
 
 (define %program-constraints
   (compose-matchers constrain:if
+                    constrain:values
+                    constrain:let
                     constrain:lambda
                     constrain:call
                     constrain:other))
-- 
cgit v1.2.3