guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] GNU Guile branch, wip-compiler, updated. v2.1.0-145-g34b


From: Noah Lavine
Subject: [Guile-commits] GNU Guile branch, wip-compiler, updated. v2.1.0-145-g34b7639
Date: Mon, 26 Dec 2011 05:12:09 +0000

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=34b76394643b4454ace2215206886f453bd1cb63

The branch, wip-compiler has been updated
       via  34b76394643b4454ace2215206886f453bd1cb63 (commit)
       via  79c6cf0eb0e0fdc406f9e860d5087f9978982499 (commit)
       via  4e6da6e5e4d25df95e6f778175868bcdc85045ef (commit)
      from  843f40aa287f7f61e1486f26e9dbc26e1904ca03 (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 34b76394643b4454ace2215206886f453bd1cb63
Author: Noah Lavine <address@hidden>
Date:   Sun Dec 25 16:47:46 2011 -0500

    New annotated-tree-il Module
    
    * module/analyzer/annotated-tree-il.scm: new module to hold
      functions that process annotated-tree-il but aren't central to
      the analyzer, like the conversion from tree-il.
    * module/analyzer/analyze.scm: remove code that goes in the new
      module.

commit 79c6cf0eb0e0fdc406f9e860d5087f9978982499
Author: Noah Lavine <address@hidden>
Date:   Sun Dec 25 10:12:13 2011 -0500

    Indentation Fixes
    
    * test-suite/tests/analyzer.test: fix indentation of pass-if
      statements

commit 4e6da6e5e4d25df95e6f778175868bcdc85045ef
Author: Noah Lavine <address@hidden>
Date:   Sun Dec 18 18:23:00 2011 -0500

    Separate Environment Code
    
    * module/analyzer/lexical-envs.scm: new file to hold the code for
      manipulating lexical environments
    * test-suite/tests/analyzer.test: test the lexical environment
      code
    * module/analyzer/analyze.scm: remove old lexical environment code

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

Summary of changes:
 module/analyzer/analyze.scm           |  278 ++-------------------------------
 module/analyzer/annotated-tree-il.scm |  234 +++++++++++++++++++++++++++
 module/analyzer/lexical-envs.scm      |   36 +++++
 test-suite/tests/analyzer.test        |  151 +++++++++++-------
 4 files changed, 375 insertions(+), 324 deletions(-)
 create mode 100644 module/analyzer/annotated-tree-il.scm
 create mode 100644 module/analyzer/lexical-envs.scm

diff --git a/module/analyzer/analyze.scm b/module/analyzer/analyze.scm
index 36f923a..65fe273 100644
--- a/module/analyzer/analyze.scm
+++ b/module/analyzer/analyze.scm
@@ -1,12 +1,10 @@
 (define-module (analyzer analyze)
   #:use-module (analyzer value-sets)
   #:use-module (analyzer set-queue)
+  #:use-module (analyzer lexical-envs)
+  #:use-module (analyzer annotated-tree-il)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 receive)
-  #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-1)
-  #:use-module (language tree-il)
-  #:use-module (system base syntax)
   #:use-module (ice-9 pretty-print)
   #:use-module (system base compile)
 
@@ -35,107 +33,19 @@ arguments.
 
 |#
 
-#|
-
-The src slot is the same as for regular tree-il. The value-set slot
-points to the value-set of this expression's return value.
-
-|#
-(define-type (<annotated-tree-il>
-              #:common-slots (src parent can-return? return-value-set))
-  ;; to do: add printer
-
-  (<a-void>)
-  (<a-const> exp)
-  (<a-primitive-ref> name)
-  (<a-lexical-ref> name gensym)
-  (<a-lexical-set> target-value-set
-                   name gensym exp)
-  (<a-module-ref> mod name public?)
-  (<a-module-set> target-value-set
-                  mod name public? exp)
-  (<a-toplevel-ref> name)
-  (<a-toplevel-set> target-value-set
-                    name exp)
-  (<a-toplevel-define> name exp)
-  (<a-conditional> test consequent alternate)
-  (<a-call> proc args)
-  (<a-seq> head tail)
-  (<a-lambda> meta body)
-  (<a-lambda-case> req opt rest kw inits gensyms body alternate)
-  (<a-let> names gensyms vals body)
-  (<a-letrec> in-order? names gensyms vals body)
-  (<a-dynlet> fluids vals body)
-  (<a-dynref> fluid)
-  (<a-dynset> target-value-set fluid exp)
-  (<a-dynwind> winder body unwinder)
-  (<a-prompt> tag body handler)
-  (<a-abort> tag args tail)
-  (<a-fix> names gensyms vals 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)
-;; entry-environment should include an entry for all of the top-level
-;; defines in the program, and any module defines that it will use.
-
-(define (make-environment)
-  '())
-
-;; append some name-value pairs to an environment
-;; environments match names to value-sets.
-(define (environment-append-pairs env . args)
-  (if (null? args)
-      env
-      (let loop ((args args)
-                 (frame '()))
-        (cond ((null? args)
-               (cons frame env))
-              ((null? (cdr args))
-               (error "environment-append-pairs" (car args)))
-              (else
-               (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)
-         => (lambda (k) k))
-        (else
-         (environment-lookup (cdr env) name))))
-
 (define default-environment
-  `( (cons . ,(value-set-with-values prim-cons))
-     (car  . ,(value-set-with-values prim-car ))
-     (cdr  . ,(value-set-with-values prim-cdr ))
-   ))
+  (environment-append-pairs (make-environment)
+    (cons 'cons (value-set-with-values prim-cons))
+    (cons 'car  (value-set-with-values prim-car))
+    (cons 'cdr  (value-set-with-values prim-cdr))))
 
 (define (primitive-lookup name)
   (environment-lookup default-environment name))
 
-(define-syntax-rule (push! 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
@@ -146,170 +56,6 @@ points to the value-set of this expression's return value.
           (set-queue-insert! *values-need-inference* parent))
          (else #t)))
 
-;; this procedure
-;; - converts tree-il to annotated tree-il.
-;; - annotates nodes with their parents.
-;; - annotates references and sets with the value-sets they use.
-;;   (it creates value-set objects, but doesn't do inference)
-;; - adds nodes to the *values-need-inference* set-queue
-(define (tree-il->annotated-tree-il! tree-il)
-  (let rec ((parent #f)
-            (tree tree-il)
-            (env default-environment))
-    (match tree
-           (($ <void> src)
-            (let ((ret 
-                   (make-a-void src parent
-                                #t ; can-return?
-                                (value-set-nothing) ; return-value-set
-                                )))
-              (child-gained-value! parent)
-              ret))
-           (($ <const> src exp)
-            (let ((ret
-                   (make-a-const src parent
-                                 #t ; can-return?
-                                 (value-set-with-values exp) ; return-value-set
-                                 exp
-                                 )))
-              (child-gained-value! parent)
-              ret))
-           (($ <primitive-ref> src name)
-            (let ((ret
-                   (make-a-primitive-ref src parent
-                                         #t ; can-return?
-                                         (primitive-lookup name) ; 
return-value-set
-                                         name)))
-              (child-gained-value! parent)
-              ret))
-           (($ <lexical-ref> src name gensym)
-            (make-a-lexical-ref src parent
-                                #t ; can-return?
-                                (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
-                                           #t ; can-return?
-                                           (value-set-nothing) ; 
return-value-set
-                                           (environment-lookup env gensym) ; 
target-value-set
-                                           name gensym
-                                           #f)))
-              (set! (a-lexical-set-exp) (rec ret exp env))
-              ret))
-           (($ <module-ref> src mod name public?)
-            (error "No module-ref yet!"))
-           (($ <module-set> src mod name public? exp)
-            (error "No module-set yet!"))
-           (($ <toplevel-ref> src name)
-            (make-a-toplevel-ref src parent
-                                 #t ; can-return?
-                                 (environment-lookup env name) ; 
return-value-set
-                                 name))
-           (($ <toplevel-set> src name exp)
-            (let ((ret (make-a-toplevel-set src parent
-                                            #t ; can-return?
-                                            (value-set-nothing) ; 
return-value-set
-                                            (environment-lookup env name) ; 
target-value-set
-                                            name
-                                            #f)))
-              (set! (a-toplevel-set-exp ret) (rec ret exp env))
-              ret))
-           (($ <toplevel-define> src name exp)
-            (error "No top level defines yet!"))
-           ;; don't need to put this in the *newly-set-value* list
-           ;; because it will be put there once the leaves in its
-           ;; definition have propagated a definition up to the top
-           ;; level. until that happens we don't know enough to infer
-           ;; anything interesting anyway.
-           (($ <conditional> src test consequent alternate)
-            (let ((ret (make-a-conditional src parent
-                                           #t ; can-return?
-                                           (value-set-nothing) ; 
return-value-set
-                                           #f #f #f)))
-              (set! (a-conditional-test ret) (rec ret test env))
-              (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))
-              (push! *verifies* ret)
-              ret))
-           (($ <call> src proc args)
-            (let ((ret (make-a-call src parent
-                                    #t ; can-return?
-                                    (value-set-nothing) ; return-value-set
-                                    #f '())))
-              (set! (a-call-proc ret) (rec ret proc env))
-              (set! (a-call-args ret) (map (lambda (x) (rec ret x env)) args))
-              ret))
-           (($ <primcall> src name args)
-            (error "No primcalls!"))
-            ;; To do: rewrite primcalls as (call (primitive-ref ...) ...)
-           (($ <seq> src head tail)
-            (let ((ret (make-a-seq src parent
-                                   #t ; can-return?
-                                   (value-set-nothing) ; return-value-set
-                                   #f #f)))
-              (set! (a-seq-head ret) (rec ret head env))
-              (set! (a-seq-tail ret) (rec ret tail env))
-              ret))
-           (($ <lambda> src meta body)
-            (let ((ret (make-a-lambda src parent
-                                 #t ; can-return?
-                                 (value-set-nothing) ; return-value-set
-                                 meta '())))
-              (set! (a-lambda-body ret) (rec ret body env))
-              ret))
-           (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
-            (error "No lambda-case right now!"))
-           (($ <let> src names gensyms vals body)
-            (let ((ret (make-a-let src parent
-                                   #t ; can-return?
-                                   #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
-                         (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
-                                      #t ; can-return?
-                                      (value-set-nothing) ; return-value-set
-                                      in-order? names gensyms
-                                      '() '())))
-              (set! (a-letrec-vals ret) (map (lambda (x) (rec ret x env)) 
vals))
-              (set! (a-letrec-body ret) (rec ret body env))
-              ret))
-           (($ <dynlet> src fluids vals body)
-            (error "No dynlet yet!"))
-           (($ <dynref> src fluid)
-            (error "No dynref yet!"))
-           (($ <dynset> src fluid exp)
-            (error "No dynset yet!"))
-           (($ <dynwind> src winder body unwinder)
-            (error "No dynwind yet!"))
-           (($ <prompt> src tag body handler)
-            (error "No prompt yet!"))
-           (($ <abort> src tag args tail)
-            (error "No abort yet!"))
-           (($ <let-values> src names gensyms exp body)
-            (error "No let-values yet!"))
-           (($ <fix> src names gensyms vals body)
-            (error "No fix yet!"))
-)))
-
 (define (all-verifies-pass?)
   (let outer ((v *verifies*))
     (if (null? v)
@@ -362,9 +108,15 @@ 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)))
+  (let ((verifies-box (make-variable '())))
+    (set! *tree*
+          (tree-il->annotated-tree-il!
+           (compile sexp #:to 'tree-il)
+           default-environment
+           verifies-box
+           (lambda (leaf) (child-gained-value!
+                      (annotated-tree-il-parent leaf)))))
+    (set! *verifies* (variable-ref verifies-box)))
   (infer-value-sets!)
   (all-verifies-pass?))
 
diff --git a/module/analyzer/annotated-tree-il.scm 
b/module/analyzer/annotated-tree-il.scm
new file mode 100644
index 0000000..a639586
--- /dev/null
+++ b/module/analyzer/annotated-tree-il.scm
@@ -0,0 +1,234 @@
+(define-module (analyzer annotated-tree-il)
+  #:use-module (analyzer value-sets)
+  #:use-module (analyzer set-queue)
+  #:use-module (analyzer lexical-envs)
+  #:use-module (ice-9 match)
+  #:use-module (system base syntax)
+  #:use-module (language tree-il)
+  #:export (annotated-tree-il-src
+            annotated-tree-il-parent
+            annotated-tree-il-can-return?
+            annotated-tree-il-return-value-set
+
+            <a-void> a-void? make-a-void
+            
+            <a-const> a-const? make-a-const a-const-exp
+            
+            <a-primitive-ref> a-primitive-ref? a-primitive-ref-name
+            
+            <a-lexical-ref> a-lexical-ref? a-lexical-ref-name
+            a-lexical-ref-gensym
+
+            <a-lexical-set> a-lexical-set? a-lexical-set-target-value-set
+            a-lexical-set-name a-lexical-set-gensym a-lexical-set-exp
+
+            <a-module-ref> a-module-ref? a-module-ref-mod a-module-ref-name
+            a-module-ref-public?
+
+            <a-module-set> a-module-set? a-module-set-target-value-set
+            a-module-set-mod a-module-set-name a-module-set-public?
+            a-module-set-exp
+
+            <a-toplevel-ref> a-toplevel-ref? a-toplevel-ref-name
+
+            <a-toplevel-set> a-toplevel-set? a-toplevel-set-target-value-set
+            a-toplevel-set-name a-toplevel-set-exp
+
+            <a-toplevel-define> a-toplevel-define? a-toplevel-define-name
+            a-toplevel-define-exp
+
+            <a-conditional> a-conditional? a-conditional-test
+            a-conditional-consequent a-conditional-alternate
+
+            <a-call> a-call? a-call-proc a-call-args
+
+            <a-seq> a-seq? a-seq-head a-seq-tail
+
+            <a-lambda> a-lambda? a-lambda-meta a-lambda-body
+
+            <a-lambda-case> a-lambda-case? a-lambda-case-req a-lambda-case-opt 
a-lambda-case-rest
+            a-lambda-case-kw a-lambda-case-inits a-lambda-case-gensyms 
a-lambda-case-body
+            a-lambda-case-alternate
+
+            <a-let> a-let? a-let-names a-let-gensyms a-let-vals a-let-body
+
+            <a-letrec> a-letrec? a-letrec-in-order? a-letrec-names
+            a-letrec-gensyms a-letrec-vals a-letrec-body
+
+            <a-dynlet> a-dynlet? a-dynlet-fluids a-dynlet-vals a-dynlet-body
+
+            <a-dynref> a-dynref? a-dynref-fluid
+
+            <a-dynset> a-dynset? a-dynset-target-value-set a-dynset-fluid
+            a-dynset-exp
+
+            <a-dynwind> a-dynwind? a-dynwind-winter a-dynwind-body
+            a-dynwind-handler
+
+            <a-prompt> a-prompt? a-prompt-tag a-prompt-body a-prompt-handler
+
+            <a-abort> a-abort? a-abort-tag a-abort-args a-abort-tail
+
+            <a-fix> a-fix? a-fix-names a-fix-gensyms a-fix-vals a-fix-body
+
+            <a-let-values> a-let-values? a-let-values-exp a-let-values-body
+
+            <a-verify> a-verify? a-verify-exps
+
+            tree-il->annotated-tree-il!))
+
+#|
+
+The src slot is the same as for regular tree-il. The value-set slot
+points to the value-set of this expression's return value.
+
+|#
+(define-type (<annotated-tree-il>
+              #:common-slots (src parent can-return? return-value-set))
+  ;; to do: add printer
+
+  (<a-void>)
+  (<a-const> exp)
+  (<a-primitive-ref> name)
+  (<a-lexical-ref> name gensym)
+  (<a-lexical-set> target-value-set
+                   name gensym exp)
+  (<a-module-ref> mod name public?)
+  (<a-module-set> target-value-set
+                  mod name public? exp)
+  (<a-toplevel-ref> name)
+  (<a-toplevel-set> target-value-set
+                    name exp)
+  (<a-toplevel-define> name exp)
+  (<a-conditional> test consequent alternate)
+  (<a-call> proc args)
+  (<a-seq> head tail)
+  (<a-lambda> meta body)
+  (<a-lambda-case> req opt rest kw inits gensyms body alternate)
+  (<a-let> names gensyms vals body)
+  (<a-letrec> in-order? names gensyms vals body)
+  (<a-dynlet> fluids vals body)
+  (<a-dynref> fluid)
+  (<a-dynset> target-value-set fluid exp)
+  (<a-dynwind> winder body unwinder)
+  (<a-prompt> tag body handler)
+  (<a-abort> tag args tail)
+  (<a-fix> names gensyms vals body)
+  (<a-let-values> exp body)
+  (<a-verify> exps))
+
+;; this procedure
+;; - converts tree-il to annotated tree-il.
+;; - annotates nodes with their parents.
+;; - annotates references and sets with the value-sets they use.
+;;   (it creates value-set objects, but doesn't do inference)
+;; - adds verify nodes to verifies, a variable object holding a list
+;; - calls leaf-func on nodes that already have values (const nodes),
+;;   after annotated with parents and value sets
+(define (tree-il->annotated-tree-il! tree-il toplevel-env verifies leaf-func)
+  (let rec ((parent #f)
+            (tree tree-il)
+            (env toplevel-env))
+    (match tree
+           (($ <void> src)
+            (error "No voids yet!"))
+           (($ <const> src exp)
+            (let ((ret
+                   (make-a-const src parent
+                                 #t ; can-return?
+                                 (value-set-with-values exp) ; return-value-set
+                                 exp
+                                 )))
+              (leaf-func ret)
+              ret))
+           (($ <primitive-ref> src name)
+            (error "No primitive-refs yet!"))
+           (($ <lexical-ref> src name gensym)
+            (make-a-lexical-ref src parent
+                                #t ; can-return?
+                                (annotated-tree-il-return-value-set
+                                 (environment-lookup env gensym)) ; 
return-value-set
+                                name gensym))
+           (($ <lexical-set> src name gensym exp)
+            (error "No lexical sets yet!"))
+           (($ <module-ref> src mod name public?)
+            (error "No module-ref yet!"))
+           (($ <module-set> src mod name public? exp)
+            (error "No module-set yet!"))
+           (($ <toplevel-ref> src name)
+            (make-a-toplevel-ref src parent
+                                 #t ; can-return?
+                                 (environment-lookup env name) ; 
return-value-set
+                                 name))
+           (($ <toplevel-set> src name exp)
+            (error "No toplevel sets yet!"))
+           (($ <toplevel-define> src name exp)
+            (error "No top level defines yet!"))
+           ;; don't need to put this in the *newly-set-value* list
+           ;; because it will be put there once the leaves in its
+           ;; definition have propagated a definition up to the top
+           ;; level. until that happens we don't know enough to infer
+           ;; anything interesting anyway.
+           (($ <conditional> src test consequent alternate)
+            (error "No conditionals yet!"))
+           (($ <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))
+              (variable-set! verifies
+                             (cons ret (variable-ref verifies)))
+              ret))
+           (($ <call> src proc args)
+            (let ((ret (make-a-call src parent
+                                    #t ; can-return?
+                                    (value-set-nothing) ; return-value-set
+                                    #f '())))
+              (set! (a-call-proc ret) (rec ret proc env))
+              (set! (a-call-args ret) (map (lambda (x) (rec ret x env)) args))
+              ret))
+           (($ <primcall> src name args)
+            (error "No primcalls!"))
+            ;; To do: rewrite primcalls as (call (primitive-ref ...) ...)
+           (($ <seq> src head tail)
+            (error "No seqs yet!"))
+           (($ <lambda> src meta body)
+            (error "No lambdas yet!"))
+           (($ <lambda-case> src req opt rest kw inits gensyms body alternate)
+            (error "No lambda-case right now!"))
+           (($ <let> src names gensyms vals body)
+            (let ((ret (make-a-let src parent
+                                   #t ; can-return?
+                                   #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
+                         (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)
+            (error "No letrecs yet!"))
+           (($ <dynlet> src fluids vals body)
+            (error "No dynlet yet!"))
+           (($ <dynref> src fluid)
+            (error "No dynref yet!"))
+           (($ <dynset> src fluid exp)
+            (error "No dynset yet!"))
+           (($ <dynwind> src winder body unwinder)
+            (error "No dynwind yet!"))
+           (($ <prompt> src tag body handler)
+            (error "No prompt yet!"))
+           (($ <abort> src tag args tail)
+            (error "No abort yet!"))
+           (($ <let-values> src names gensyms exp body)
+            (error "No let-values yet!"))
+           (($ <fix> src names gensyms vals body)
+            (error "No fix yet!"))
+)))
diff --git a/module/analyzer/lexical-envs.scm b/module/analyzer/lexical-envs.scm
new file mode 100644
index 0000000..d330e7b
--- /dev/null
+++ b/module/analyzer/lexical-envs.scm
@@ -0,0 +1,36 @@
+(define-module (analyzer lexical-envs)
+  #:export (make-environment
+            environment-append-pairs
+            environment-append-names-values
+            environment-lookup))
+
+;; we will represent environments as association lists.
+
+(define (make-environment)
+  '())
+
+;; append some name-value pairs to an environment
+;; environments match names to value-sets.
+(define (environment-append-pairs env . args)
+  (let inner ((arg-lst args))
+    (if (null? arg-lst)
+        env
+        (cons (car arg-lst)
+              (inner (cdr arg-lst))))))
+
+;; the difference between environment-append-pairs and
+;; environment-append-names-values is that in the first one, you have
+;; pairs of (name, value), and in the second, you have a list of names
+;; and a matching list of values
+
+(define (environment-append-names-values env names values)
+  (cond ((and (null? names) (null? values))
+         env)
+        ((or (null? names) (null? values))
+         (error "environment-append-names-values got different-length lists!"))
+        (else
+         (cons (cons (car names) (car values))
+               (environment-append-names-values env (cdr names) (cdr 
values))))))
+
+(define (environment-lookup env name)
+  (assq-ref env name))
diff --git a/test-suite/tests/analyzer.test b/test-suite/tests/analyzer.test
index 2d935b9..d057002 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 lexical-envs)
              (analyzer value-sets)
              (analyzer analyze))
 
@@ -8,41 +9,69 @@
 (define sq (make-set-queue))
 
 (pass-if "set-queue-insert!"
-         (begin
-           (set-queue-insert! sq 1)
-           (set-queue-insert! sq 2)
-           (set-queue-insert! sq 3)
-           #t)) ;; pass if you get here without an exception
+  (begin
+    (set-queue-insert! sq 1)
+    (set-queue-insert! sq 2)
+    (set-queue-insert! sq 3)
+    #t)) ;; pass if you get here without an exception
 
 (pass-if "set-queue-remove"
-         (equal? (set-queue-remove! sq) 1))
+  (equal? (set-queue-remove! sq) 1))
 
 (pass-if "set-queue-remove"
-         (equal? (set-queue-remove! sq) 2))
+  (equal? (set-queue-remove! sq) 2))
 
 (pass-if "set-queue-empty?"
-         (not (set-queue-empty? sq)))
+  (not (set-queue-empty? sq)))
 
 (pass-if "set-queue-remove"
-         (equal? (set-queue-remove! sq) 3))
+  (equal? (set-queue-remove! sq) 3))
 
 (pass-if "set-queue-empty?"
-         (set-queue-empty? sq))
+  (set-queue-empty? sq))
 
 (pass-if "set-queue-insert!"
-         (begin
-           (set-queue-insert! sq 1)
-           (set-queue-insert! sq 2)
-           (set-queue-insert! sq 3)
-           
-           (set-queue-insert! sq 1)
-           #t))
+  (begin
+    (set-queue-insert! sq 1)
+    (set-queue-insert! sq 2)
+    (set-queue-insert! sq 3)
+    
+    (set-queue-insert! sq 1)
+    #t))
 
 (define lst '())
 (pass-if "emptying-set-queue"
-         (begin
-           (emptying-set-queue! sq (lambda (x) (set! lst (cons x lst))))
-           (equal? lst '(3 2 1))))
+  (begin
+    (emptying-set-queue! sq (lambda (x) (set! lst (cons x lst))))
+    (equal? lst '(3 2 1))))
+
+;; test the environment functions
+
+(define env (make-environment))
+
+(pass-if "lookup in empty environment"
+  (not (environment-lookup env 'foo)))
+
+(define env-a
+  (environment-append-pairs env
+                            (cons 'a 'b)
+                            (cons 'c 'd)
+                            (cons 'e 'f)))
+
+(pass-if "basic environment lookup"
+  (and (eq? (environment-lookup env-a 'a) 'b)
+       (eq? (environment-lookup env-a 'c) 'd)
+       (eq? (environment-lookup env-a 'e) 'f)))
+
+(define env-b
+  (environment-append-names-values env-a
+                                   '(a c e)
+                                   '(g h i)))
+
+(pass-if "shadowed bindings in environment"
+  (and (eq? (environment-lookup env-b 'a) 'g)
+       (eq? (environment-lookup env-b 'c) 'h)
+       (eq? (environment-lookup env-b 'e) 'i)))
 
 ;; test the value set functions
 
@@ -53,47 +82,47 @@
 (define (true? x) (not (not x)))
 
 (pass-if "value-set-can-be-anything?"
-         (value-set-can-be-anything? anything))
+  (value-set-can-be-anything? anything))
 
 (pass-if "value-set-value-satisfying"
-         (true? (value-set-value-satisfying simple number?)))
+  (true? (value-set-value-satisfying simple number?)))
 
 (pass-if "value-set-value-satisfying"
-         (not (value-set-value-satisfying nothing number?)))
+  (not (value-set-value-satisfying nothing number?)))
 
 (pass-if "value-set-has-values?"
-         (not (value-set-has-values? nothing)))
+  (not (value-set-has-values? nothing)))
 (pass-if "value-set-has-values?"
-         (value-set-has-values? anything))
+  (value-set-has-values? anything))
 (pass-if "value-set-has-values?"
-         (value-set-has-values? simple))
+  (value-set-has-values? simple))
 
 (pass-if "value-set-has-value?"
-         (true? (value-set-has-value? simple 3)))
+  (true? (value-set-has-value? simple 3)))
 
 (pass-if "value-set-has-value?"
-         (not (value-set-has-value? nothing 4)))
+  (not (value-set-has-value? nothing 4)))
 
 (pass-if "value-set-has-property?"
-         (true? (value-set-has-property? anything 'anything)))
+  (true? (value-set-has-property? anything 'anything)))
 (pass-if "value-set-has-property?"
-         (not (value-set-has-property? simple 'anything)))
+  (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))))
+  (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?))))
+  (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?))))
+  (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))))
+  (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))
@@ -102,16 +131,16 @@
 (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))))
+  (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))))
+  (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))
@@ -119,38 +148,38 @@
 (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))))
+  (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))))
+  (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))))
+  (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))))
+  (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))))
+  (not (go '(verify #f))))
 
 (pass-if "(verify #t)"
-         (true? (go '(verify #t))))
+  (true? (go '(verify #t))))
 
 (pass-if "(verify #t #t #t)"
-         (true? (go '(verify #t #t #t))))
+  (true? (go '(verify #t #t #t))))
 
 (pass-if "(verify #t #f #t)"
-         (not (go '(verify #t #f #t))))
+  (not (go '(verify #t #f #t))))
 
 (pass-if "verify outside a let"
-         (go '(verify (let ((x #t)) x))))
+  (go '(verify (let ((x #t)) x))))
 
 (pass-if "verify inside a let"
-         (go '(let ((x #t))
-                (verify x))))
+  (go '(let ((x #t))
+         (verify x))))


hooks/post-receive
-- 
GNU Guile



reply via email to

[Prev in Thread] Current Thread [Next in Thread]