summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNoah Lavine <noah.b.lavine@gmail.com>2011-12-18 18:23:00 -0500
committerNoah Lavine <noah.b.lavine@gmail.com>2011-12-18 18:23:00 -0500
commit4e6da6e5e4d25df95e6f778175868bcdc85045ef (patch)
treed6ea4b0e5c9cebe1a9eb7a6e883dfccffcd2e9fc
parent843f40aa287f7f61e1486f26e9dbc26e1904ca03 (diff)
downloadguile-4e6da6e5e4d25df95e6f778175868bcdc85045ef.tar.gz
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
-rw-r--r--module/analyzer/analyze.scm53
-rw-r--r--module/analyzer/lexical-envs.scm36
-rw-r--r--test-suite/tests/analyzer.test29
3 files changed, 70 insertions, 48 deletions
diff --git a/module/analyzer/analyze.scm b/module/analyzer/analyze.scm
index 36f923a72..b24742845 100644
--- a/module/analyzer/analyze.scm
+++ b/module/analyzer/analyze.scm
@@ -1,6 +1,7 @@
(define-module (analyzer analyze)
#:use-module (analyzer value-sets)
#:use-module (analyzer set-queue)
+ #:use-module (analyzer lexical-envs)
#:use-module (ice-9 match)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-9)
@@ -75,55 +76,11 @@ points to the value-set of this expression's return value.
(<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))
diff --git a/module/analyzer/lexical-envs.scm b/module/analyzer/lexical-envs.scm
new file mode 100644
index 000000000..d330e7ba4
--- /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 2d935b99b..36ecccc61 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))
@@ -44,6 +45,34 @@
(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
(define nothing (value-set-nothing))