[Guile-commits] GNU Guile branch, wip-compiler, updated. v2.1.0-140-g14654b5

[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=14654b5b0fe9bfdea7f02c03774bd4f389607f41

The branch, wip-compiler has been updated
       via  14654b5b0fe9bfdea7f02c03774bd4f389607f41 (commit)
      from  f8a333e8a5468b57f22b1a139b18f8e1a0d706fe (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 14654b5b0fe9bfdea7f02c03774bd4f389607f41
Author: Noah Lavine <address@hidden>
Date:   Sat Dec 17 10:29:35 2011 -0500

    Add verify
    
    * module/analyzer/analyze.scm: recognize the 'verify' function as
      special, and add infrastructure for making sure that all verifies
      pass.
    * test-suite/tests/analyzer.test: add the most basic tests for
      verify.

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

Summary of changes:
 module/analyzer/analyze.scm    |   43 ++++++++++++++++++++++++++++++++-------
 test-suite/tests/analyzer.test |   10 ++++++++-
 2 files changed, 44 insertions(+), 9 deletions(-)

diff --git a/module/analyzer/analyze.scm b/module/analyzer/analyze.scm
index f3590c0..d705626 100644
--- a/module/analyzer/analyze.scm
+++ b/module/analyzer/analyze.scm
@@ -115,10 +115,23 @@ points to the value-set of this expression's return value.
   (environment-lookup default-environment name))
 
 (define-syntax-rule (push! list obj)
-  (set! list (cons list obj)))
+  (set! list (cons obj list)))
 
 (define *values-need-inference* (make-set-queue))
 
+(define *verifies* '())
+
+
+;; this procedure is called on a node whose child node gained a
+;; value. it decides what to do about this. the parent can be #f, which
+;; means the child is at the top level
+(define (child-gained-value! parent)
+  (match parent
+         (#f #t)
+         (($ <a-call> _ _ _ _ _ _)
+          (set-queue-insert! *values-need-inference* parent))
+         (else #t)))
+
 ;; this procedure
 ;; - converts tree-il to annotated tree-il.
 ;; - annotates nodes with their parents.
@@ -136,8 +149,7 @@ points to the value-set of this expression's return value.
                                 #t ; can-return?
                                 (value-set-nothing) ; return-value-set
                                 )))
-              (if parent
-                  (set-queue-insert! *values-need-inference* parent))
+              (child-gained-value! parent)
               ret))
            (($ <const> src exp)
             (let ((ret
@@ -146,8 +158,7 @@ points to the value-set of this expression's return value.
                                  (value-set-with-values exp) ; return-value-set
                                  exp
                                  )))
-              (if parent
-                  (set-queue-insert! *values-need-inference* parent))
+              (child-gained-value! parent)
               ret))
            (($ <primitive-ref> src name)
             (let ((ret
@@ -155,8 +166,7 @@ points to the value-set of this expression's return value.
                                          #t ; can-return?
                                          (primitive-lookup name) ; 
return-value-set
                                          name)))
-              (if parent
-                  (set-queue-insert! *values-need-inference* parent))
+              (child-gained-value! parent)
               ret))
            (($ <lexical-ref> src name gensym)
             (make-a-lexical-ref src parent
@@ -213,6 +223,7 @@ points to the value-set of this expression's return value.
                                       '())))
               (set! (a-verify-exps ret)
                     (map (lambda (x) (rec ret x env)) args))
+              (push! *verifies* ret)
               ret))
            (($ <call> src proc args)
             (let ((ret (make-a-call src parent
@@ -278,6 +289,20 @@ points to the value-set of this expression's return value.
             (error "No fix yet!"))
 )))
 
+(define (all-verifies-pass?)
+  (let outer ((v *verifies*))
+    (if (null? v)
+        #t
+        (let inner ((exps (a-verify-exps (car v))))
+          (cond ((null? exps) (outer (cdr v)))
+                ((and (value-set-has-values?
+                       (annotated-tree-il-return-value-set (car exps)))
+                      (not (value-set-has-value?
+                            (annotated-tree-il-return-value-set (car exps))
+                            #f)))
+                 (inner (cdr exps)))
+                (else #f))))))
+
 (define *tree* '())
 
 ;; This function starts with the annotated tree-il nodes in
@@ -315,10 +340,12 @@ points to the value-set of this expression's return value.
 
 (define (go sexp)
   (set! *values-need-inference* (make-set-queue))
+  (set! *verifies* '())
   (set! *tree*
    (tree-il->annotated-tree-il!
     (compile sexp #:to 'tree-il)))
-  (pretty-print *tree*))
+  (infer-value-sets!)
+  (all-verifies-pass?))
 
 #|
 
diff --git a/test-suite/tests/analyzer.test b/test-suite/tests/analyzer.test
index 9e9ac3c..1206caa 100644
--- a/test-suite/tests/analyzer.test
+++ b/test-suite/tests/analyzer.test
@@ -1,6 +1,7 @@
 (use-modules (test-suite lib)
              (analyzer set-queue)
-             (analyzer value-sets))
+             (analyzer value-sets)
+             (analyzer analyze))
 
 ;; test the set queue functions
 
@@ -133,3 +134,10 @@
          (begin (vs-cdr vs-t4 (value-set-nothing))
                 (true? (value-set-nothing? vs-t4))))
 
+;; test the actual analyzer!
+
+(pass-if "(verify #f)"
+         (not (go '(verify #f))))
+
+(pass-if "(verify #t)"
+         (true? (go '(verify #t))))


hooks/post-receive
-- 
GNU Guile