diff options
author | Noah Lavine <nlavine@haverford.edu> | 2011-12-17 13:30:05 -0500 |
---|---|---|
committer | Noah Lavine <nlavine@haverford.edu> | 2011-12-17 13:30:05 -0500 |
commit | 843f40aa287f7f61e1486f26e9dbc26e1904ca03 (patch) | |
tree | 56211492cd67ac32d08b9aa6e1011d86ab79754f | |
parent | 77dd276620ce610cfe33a2409b3366d262201453 (diff) | |
download | guile-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.scm | 27 | ||||
-rw-r--r-- | test-suite/tests/analyzer.test | 7 |
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)))) |