[Guile-commits] GNU Guile branch, wip-compiler, updated. v2.1.0-139-gf8a333e

[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=f8a333e8a5468b57f22b1a139b18f8e1a0d706fe

The branch, wip-compiler has been updated
       via  f8a333e8a5468b57f22b1a139b18f8e1a0d706fe (commit)
       via  6302eb94191ed0b17306048a38b90e5e7ee78133 (commit)
       via  bb32549299e2b3228562a3202787ef0499950b47 (commit)
       via  e37647d353f717e49fc4821c01f5e07c78a95269 (commit)
       via  a568ece7736a918d8c7f95e58c9737465be42020 (commit)
      from  71ba0cb43e650bb63a20416a4c0f593763429a7c (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 f8a333e8a5468b57f22b1a139b18f8e1a0d706fe
Author: Noah Lavine <address@hidden>
Date:   Wed Dec 14 22:39:05 2011 -0500

    Add verify Nodes
    
    * module/analyzer/analyze.scm: add <a-verify> option to
      annotated-tree-il, and have tree-il->annotated-tree-il! generate
      it.

commit 6302eb94191ed0b17306048a38b90e5e7ee78133
Author: Noah Lavine <address@hidden>
Date:   Wed Dec 14 21:16:28 2011 -0500

    Prepare for Analyzing
    
    * module/analyzer/analyze.scm: the first-draft of a real analyzer.

commit bb32549299e2b3228562a3202787ef0499950b47
Author: Noah Lavine <address@hidden>
Date:   Wed Dec 14 21:15:32 2011 -0500

    More value-set Tests
    
    * test-suite/tests/analyzer.test: test vs-car, vs-cdr and vs-cons
    * module/analyzer/value-sets.scm: bug fixes

commit e37647d353f717e49fc4821c01f5e07c78a95269
Author: Noah Lavine <address@hidden>
Date:   Wed Dec 14 20:35:41 2011 -0500

    Value Set Unions
    
    * module/analyzer/value-sets.scm: add the basic union operation,
      and its two special cases add-value! and add-property!
    * test-suite/tests/analyzer.test: add tests for the value set
      union operations.

commit a568ece7736a918d8c7f95e58c9737465be42020
Author: Noah Lavine <address@hidden>
Date:   Tue Dec 13 19:15:30 2011 -0500

    Test value-sets
    
    * test-suite/tests/analyzer.test: add tests for (analyzer value-sets)

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

Summary of changes:
 module/analyzer/analyze.scm    |   33 ++++++++++---
 module/analyzer/value-sets.scm |  102 +++++++++++++++++++++++++++++++++-------
 test-suite/tests/analyzer.test |   94 ++++++++++++++++++++++++++++++++++++-
 3 files changed, 204 insertions(+), 25 deletions(-)

diff --git a/module/analyzer/analyze.scm b/module/analyzer/analyze.scm
index 2e8c598..f3590c0 100644
--- a/module/analyzer/analyze.scm
+++ b/module/analyzer/analyze.scm
@@ -72,7 +72,8 @@ points to the value-set of this expression's return value.
   (<a-prompt> tag body handler)
   (<a-abort> tag args tail)
   (<a-fix> names gensyms vals body)
-  (<a-let-values> exp body))
+  (<a-let-values> exp body)
+  (<a-verify> exps))
 
 ;; this returns a value-set for its tree's return value and a new
 ;; environment to replace entry-environment (in case it's a set form)
@@ -105,9 +106,9 @@ points to the value-set of this expression's return value.
          (environment-lookup (cdr env) name))))
 
 (define default-environment
-  `( (cons . ,(value-set-with-values 'cons))
-     (car  . ,(value-set-with-values 'car))
-     (cdr  . ,(value-set-with-values 'cdr))
+  `( (cons . ,(value-set-with-values prim-cons))
+     (car  . ,(value-set-with-values prim-car ))
+     (cdr  . ,(value-set-with-values prim-cdr ))
    ))
 
 (define (primitive-lookup name)
@@ -205,6 +206,14 @@ points to the value-set of this expression's return value.
               (set! (a-conditional-consequent ret) (rec ret consequent env))
               (set! (a-conditional-alternate ret) (rec ret alternate env))
               ret))
+           (($ <call> src ($ <toplevel-ref> tsrc 'verify) args)
+            (let ((ret (make-a-verify src parent
+                                      #f ; can-return?
+                                      (value-set-nothing) ; return-value-se
+                                      '())))
+              (set! (a-verify-exps ret)
+                    (map (lambda (x) (rec ret x env)) args))
+              ret))
            (($ <call> src proc args)
             (let ((ret (make-a-call src parent
                                     #t ; can-return?
@@ -287,12 +296,22 @@ points to the value-set of this expression's return value.
                      proc args)
          (if (and (value-set-has-values?
                    (annotated-tree-il-return-value-set proc))
+                  (value-set-has-no-properties?
+                   (annotated-tree-il-return-value-set proc))
                   (every (lambda (x) (value-set-has-values?
                                  (annotated-tree-il-return-value-set x)))
                          args))
-             (begin
-               ))))
-)))
+             (let loop ((procs (value-set-values
+                                (annotated-tree-il-return-value-set proc))))
+               (if (not (null? procs))
+                   (begin
+                     (let ((eval (primitive-procedure-evaluator (car procs))))
+                       (apply eval return-value-set
+                              (map annotated-tree-il-return-value-set
+                                   args)))
+                     (loop (cdr procs)))))
+             )))
+      )))
 
 (define (go sexp)
   (set! *values-need-inference* (make-set-queue))
diff --git a/module/analyzer/value-sets.scm b/module/analyzer/value-sets.scm
index 3c23d4b..f7aa3b7 100644
--- a/module/analyzer/value-sets.scm
+++ b/module/analyzer/value-sets.scm
@@ -1,5 +1,6 @@
 (define-module (analyzer value-sets)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-1)
   #:export (value-set value-set-type
                       make-value-set value-set?
                       value-set-values set-value-set-values!
@@ -7,8 +8,25 @@
 
             value-set-nothing value-set-anything
             value-set-can-be-anything? value-set-has-values?
+            value-set-has-value? value-set-has-property?
+            value-set-nothing? value-set-has-no-properties?
             value-set-with-values
-            value-set-value-satisfying))
+            value-set-value-satisfying
+            
+            value-set-union!
+            value-set-add-value!
+            value-set-add-property!
+
+            vs-cons
+            vs-car
+            vs-cdr
+
+            primitive-procedure-type
+            primitive-procedure
+            primitive-procedure?
+            primitive-procedure-evaluator
+
+            prim-cons prim-car prim-cdr))
 
 #|
 
@@ -48,7 +66,7 @@
   (values value-set-values set-value-set-values!)
   (properties value-set-properties set-value-set-properties!))
 
-; convenience constructors
+;; convenience constructors
 (define (value-set-anything)
   (value-set '() '((anything))))
 (define (value-set-nothing)
@@ -56,7 +74,7 @@
 (define (value-set-with-values . vals)
   (value-set vals '()))
 
-; and predicates
+;; and predicates
 (define (value-set-has-values? vs)
   (or (not (null? (value-set-values vs)))
       (not (null? (value-set-properties vs)))))
@@ -67,37 +85,87 @@
           ((eq? (caar props) 'anything) #t)
           (else (loop (cdr props))))))
 
-; and a selector
+(define (value-set-nothing? vs)
+  (and (null? (value-set-values vs))
+       (null? (value-set-properties vs))))
+
+(define (value-set-has-value? vs v)
+  (memq v (value-set-values vs)))
+
+(define (value-set-has-property? vs p)
+  (assq p (value-set-properties vs)))
+
+(define (value-set-has-no-properties? vs)
+  (null? (value-set-properties vs)))
+
+;; and a selector
 (define (value-set-value-satisfying vs pred)
   (let loop ((vals (value-set-values vs)))
     (cond ((null? vals) #f)
           ((pred (car vals)) (car vals))
           (else (loop (cdr vals))))))
 
+;; and three modifiers. these are really three cases of the same thing -
+;; a general case and two special ones. they are the basic operation on
+;; value sets.
+
+;; this function sets t to the union of t and x.
+;; it uses a recursive merge if one of the values is a pair.
+(define (value-set-union! t x)
+  (cond ((value-set-can-be-anything? x)
+         (set-value-set-values! t '())
+         (set-value-set-properties! t '((anything))))
+        (else
+         (for-each (lambda (v) (value-set-add-value! t v))
+                   (value-set-values x))
+         (for-each (lambda (p) (value-set-add-property! t p))
+                   (value-set-properties x)))))
+
+(define (value-set-add-value! t v)
+  (if (pair? v)
+      (let ((old-pair (value-set-value-satisfying t pair?)))
+        (if old-pair
+            (begin (value-set-union! (car old-pair) (car v))
+                   (value-set-union! (cdr old-pair) (cdr v)))
+            (set-value-set-values! t (cons v (value-set-values t)))))
+      (if (not (memv v (value-set-values t)))
+          (set-value-set-values! t (cons v (value-set-values t))))))
+
+(define (value-set-add-property! t p)
+  (cond ((equal? p '(anything))
+         (set-value-set-properties! t '((anything)))
+         (set-value-set-values! t '()))
+        ((equal? p '(number?))
+         (set-value-set-properties! t '((number?))))
+        (else
+         (error "Don't know how to add property" p))))
+
 (define-record-type primitive-procedure-type
   ;; this type holds the value-set version of a primitive procedure
   (primitive-procedure evaluator)
   primitive-procedure?
   (evaluator primitive-procedure-evaluator))
 
-(define (vs-cons a b)
-  (values
-   (value-set (list (cons a b))
-              '())
-   '()))
+;; all procedures take an extra first argument, the "target", which is
+;; the value set of their return value.
+(define (vs-cons t a b)
+  (value-set-add-value! t
+                        (cons a b)))
 
-(define (vs-car p)
+(define (vs-car t p)
   (if (value-set-can-be-anything? p)
-      (value-set-anything)
+      (value-set-union! t (value-set-anything))
       (let ((pair (value-set-value-satisfying p pair?)))
         (if pair
-            (car pair)
-            (value-set-nothing)))))
+            (value-set-union! t (car pair))))))
 
-(define (vs-cdr p)
+(define (vs-cdr t p)
   (if (value-set-can-be-anything? p)
-      (value-set-anything)
+      (value-set-union! t (value-set-anything))
       (let ((pair (value-set-value-satisfying p pair?)))
         (if pair
-            (car pair)
-            (value-set-nothing)))))
+            (value-set-union! t (cdr pair))))))
+
+(define prim-cons (primitive-procedure vs-cons))
+(define prim-car  (primitive-procedure vs-car))
+(define prim-cdr  (primitive-procedure vs-cdr))
diff --git a/test-suite/tests/analyzer.test b/test-suite/tests/analyzer.test
index 21bbaa3..9e9ac3c 100644
--- a/test-suite/tests/analyzer.test
+++ b/test-suite/tests/analyzer.test
@@ -1,5 +1,6 @@
 (use-modules (test-suite lib)
-             (analyzer set-queue))
+             (analyzer set-queue)
+             (analyzer value-sets))
 
 ;; test the set queue functions
 
@@ -41,3 +42,94 @@
          (begin
            (emptying-set-queue! sq (lambda (x) (set! lst (cons x lst))))
            (equal? lst '(3 2 1))))
+
+;; test the value set functions
+
+(define nothing (value-set-nothing))
+(define anything (value-set-anything))
+(define simple (value-set-with-values 1 2 3))
+
+(define (true? x) (not (not x)))
+
+(pass-if "value-set-can-be-anything?"
+         (value-set-can-be-anything? anything))
+
+(pass-if "value-set-value-satisfying"
+         (true? (value-set-value-satisfying simple number?)))
+
+(pass-if "value-set-value-satisfying"
+         (not (value-set-value-satisfying nothing number?)))
+
+(pass-if "value-set-has-values?"
+         (not (value-set-has-values? nothing)))
+(pass-if "value-set-has-values?"
+         (value-set-has-values? anything))
+(pass-if "value-set-has-values?"
+         (value-set-has-values? simple))
+
+(pass-if "value-set-has-value?"
+         (true? (value-set-has-value? simple 3)))
+
+(pass-if "value-set-has-value?"
+         (not (value-set-has-value? nothing 4)))
+
+(pass-if "value-set-has-property?"
+         (true? (value-set-has-property? anything 'anything)))
+(pass-if "value-set-has-property?"
+         (not (value-set-has-property? simple 'anything)))
+
+(pass-if "union value 4 onto other numbers"
+         (begin (value-set-add-value! simple 4)
+                (true? (value-set-has-value? simple 4))))
+
+(pass-if "add property (number?)"
+         (begin (value-set-add-property! nothing '(number?))
+                (true? (value-set-has-property? nothing 'number?))))
+
+(pass-if "add property (anything), no other properties"
+         (begin (value-set-add-property! nothing '(anything))
+                (not (value-set-has-property? nothing 'number?))))
+
+(pass-if "add property (anything), no values"
+         (begin (value-set-add-property! simple '(anything))
+                (not (value-set-has-value? simple 3))))
+
+(define vs-one (value-set-with-values 1))
+(define vs-two (value-set-with-values 2))
+(define vs-three (value-set-with-values 3))
+(define vs-four (value-set-with-values 4))
+(define vs-pair (value-set-nothing))
+
+(pass-if "union a pair value onto something without a pair value"
+         (begin (vs-cons vs-pair vs-one vs-two)
+                (true? (value-set-has-value?
+                        (car (value-set-value-satisfying vs-pair pair?))
+                        1))))
+
+(pass-if "union a pair value onto another pair value"
+         (begin (vs-cons vs-pair vs-three vs-four)
+                (true? (value-set-has-value?
+                        (car (value-set-value-satisfying vs-pair pair?))
+                        1))))
+
+(define vs-t1 (value-set-nothing))
+(define vs-t2 (value-set-nothing))
+(define vs-t3 (value-set-nothing))
+(define vs-t4 (value-set-nothing))
+
+(pass-if "take a vs-car of a pair"
+         (begin (vs-car vs-t1 vs-pair)
+                (true? (value-set-has-value? vs-t1 3))))
+
+(pass-if "take a vs-car of nothing"
+         (begin (vs-car vs-t2 (value-set-nothing))
+                (true? (value-set-nothing? vs-t2))))
+
+(pass-if "take a vs-cdr of a pair"
+         (begin (vs-cdr vs-t3 vs-pair)
+                (true? (value-set-has-value? vs-t3 4))))
+
+(pass-if "take a vs-cdr of nothing"
+         (begin (vs-cdr vs-t4 (value-set-nothing))
+                (true? (value-set-nothing? vs-t4))))
+


hooks/post-receive
-- 
GNU Guile