diff options
author | Noah Lavine <noah.b.lavine@gmail.com> | 2011-12-18 18:23:00 -0500 |
---|---|---|
committer | Noah Lavine <noah.b.lavine@gmail.com> | 2011-12-18 18:23:00 -0500 |
commit | 4e6da6e5e4d25df95e6f778175868bcdc85045ef (patch) | |
tree | d6ea4b0e5c9cebe1a9eb7a6e883dfccffcd2e9fc | |
parent | 843f40aa287f7f61e1486f26e9dbc26e1904ca03 (diff) | |
download | guile-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.scm | 53 | ||||
-rw-r--r-- | module/analyzer/lexical-envs.scm | 36 | ||||
-rw-r--r-- | test-suite/tests/analyzer.test | 29 |
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)) |