summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorDavid Thompson <dthompson2@worcester.edu>2023-01-07 08:56:08 -0500
committerDavid Thompson <dthompson2@worcester.edu>2023-06-08 08:14:41 -0400
commitc8d737284e631e626bc629469d77c2abb5d3847e (patch)
treee80127687a76f879e9a643ff2d1ff5e31e9012d2
parent8378e87ac770a12a95c544ecf1ad80692dc5d20c (diff)
Add let and values forms.
-rw-r--r--infer2.scm37
1 files changed, 37 insertions, 0 deletions
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))