[Guile-commits] GNU Guile branch, wip-compiler, updated. v2.1.0-142-g843f40a

[Noah Lavine]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=843f40aa287f7f61e1486f26e9dbc26e1904ca03

The branch, wip-compiler has been updated
       via  843f40aa287f7f61e1486f26e9dbc26e1904ca03 (commit)
       via  77dd276620ce610cfe33a2409b3366d262201453 (commit)
      from  14654b5b0fe9bfdea7f02c03774bd4f389607f41 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 843f40aa287f7f61e1486f26e9dbc26e1904ca03
Author: Noah Lavine <address@hidden>
Date:   Sat Dec 17 13:30:05 2011 -0500

    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.

commit 77dd276620ce610cfe33a2409b3366d262201453
Author: Noah Lavine <address@hidden>
Date:   Sat Dec 17 13:05:39 2011 -0500

    More verify Tests
    
    * test-suite/tests/analyzer.test: test that verify works correctly
      with multiple expressions.

-----------------------------------------------------------------------

Summary of changes:
 module/analyzer/analyze.scm    |   27 ++++++++++++++++++++++++---
 test-suite/tests/analyzer.test |   13 +++++++++++++
 2 files changed, 37 insertions(+), 3 deletions(-)

diff --git a/module/analyzer/analyze.scm b/module/analyzer/analyze.scm
index d705626..36f923a 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 1206caa..2d935b9 100644
--- a/test-suite/tests/analyzer.test
+++ b/test-suite/tests/analyzer.test
@@ -141,3 +141,16 @@
 
 (pass-if "(verify #t)"
          (true? (go '(verify #t))))
+
+(pass-if "(verify #t #t #t)"
+         (true? (go '(verify #t #t #t))))
+
+(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))))


hooks/post-receive
-- 
GNU Guile