summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNoah Lavine <nlavine@haverford.edu>2011-12-17 13:30:05 -0500
committerNoah Lavine <nlavine@haverford.edu>2011-12-17 13:30:05 -0500
commit843f40aa287f7f61e1486f26e9dbc26e1904ca03 (patch)
tree56211492cd67ac32d08b9aa6e1011d86ab79754f
parent77dd276620ce610cfe33a2409b3366d262201453 (diff)
downloadguile-843f40aa287f7f61e1486f26e9dbc26e1904ca03.tar.gz
Analyze let and lexical-ref
* module/analyzer/analyze.scm: let and lexical-ref are now handled well enough that verifies work both inside and outside a let form. * test-suite/tests/analyzer.test: check that lets and lexical-refs are checked.
-rw-r--r--module/analyzer/analyze.scm27
-rw-r--r--test-suite/tests/analyzer.test7
2 files changed, 31 insertions, 3 deletions
diff --git a/module/analyzer/analyze.scm b/module/analyzer/analyze.scm
index d70562660..36f923a72 100644
--- a/module/analyzer/analyze.scm
+++ b/module/analyzer/analyze.scm
@@ -98,6 +98,20 @@ points to the value-set of this expression's return value.
(loop (cddr args)
(cons (cons (car args) (cadr args)) frame)))))))
+(define (environment-append-names-values env names values)
+ (let loop ((frame '())
+ (names names)
+ (values values))
+ (cond ((null? names)
+ (if (null? values)
+ (cons frame env)
+ (error "environment-append-names-values: got different-length lists!")))
+ ((null? values)
+ (error "environment-append-names-values: got different-length lists!"))
+ (else (loop (cons (cons (car names) (car values)) frame)
+ (cdr names)
+ (cdr values))))))
+
(define (environment-lookup env name)
(cond ((null? env) #f)
((assq-ref (car env) name)
@@ -171,7 +185,8 @@ points to the value-set of this expression's return value.
(($ <lexical-ref> src name gensym)
(make-a-lexical-ref src parent
#t ; can-return?
- (environment-lookup env gensym) ; return-value-set
+ (annotated-tree-il-return-value-set
+ (environment-lookup env gensym)) ; return-value-set
name gensym))
(($ <lexical-set> src name gensym exp)
(let ((ret (make-a-lexical-set src parent
@@ -256,11 +271,17 @@ points to the value-set of this expression's return value.
(($ <let> src names gensyms vals body)
(let ((ret (make-a-let src parent
#t ; can-return?
- (value-set-nothing) ; return-value-set
+ #f ; return-value-set
names gensyms
'() '())))
(set! (a-let-vals ret) (map (lambda (x) (rec ret x env)) vals))
- (set! (a-let-body ret) (rec ret body env))
+ (set! (a-let-body ret)
+ (rec ret body
+ (environment-append-names-values env
+ gensyms
+ (a-let-vals ret))))
+ (set! (annotated-tree-il-return-value-set ret)
+ (annotated-tree-il-return-value-set (a-let-body ret)))
ret))
(($ <letrec> src in-order? names gensyms vals body)
(let ((ret (make-a-letrec src parent
diff --git a/test-suite/tests/analyzer.test b/test-suite/tests/analyzer.test
index d75cc3ca9..2d935b99b 100644
--- a/test-suite/tests/analyzer.test
+++ b/test-suite/tests/analyzer.test
@@ -147,3 +147,10 @@
(pass-if "(verify #t #f #t)"
(not (go '(verify #t #f #t))))
+
+(pass-if "verify outside a let"
+ (go '(verify (let ((x #t)) x))))
+
+(pass-if "verify inside a let"
+ (go '(let ((x #t))
+ (verify x))))