~ chicken-core (chicken-5) c7417d3e9112ff5fd2e18e171a755e73118b2301
commit c7417d3e9112ff5fd2e18e171a755e73118b2301
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jul 29 14:40:07 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Jul 29 14:40:07 2011 +0200
added module-environment; refactored lookup of import lib; module saved-envs include val+syntax exports; added env tests; fixed overly general result-type decls for r5rs env procs
diff --git a/chicken.import.scm b/chicken.import.scm
index 722094df..35860dd1 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -174,6 +174,7 @@
maximum-flonum
memory-statistics
minimum-flonum
+ module-environment
most-negative-fixnum
most-positive-fixnum
on-exit
diff --git a/eval.scm b/eval.scm
index 2b76a14d..6260409b 100644
--- a/eval.scm
+++ b/eval.scm
@@ -1333,8 +1333,8 @@
(##sys#write-char-0 #\> p))
(define scheme-report-environment
- (let ((r4 (##sys#module-environment 'r4rs 'scheme-report-environment/4))
- (r5 (##sys#module-environment 'scheme 'scheme-report-environment/5)))
+ (let ((r4 (module-environment 'r4rs 'scheme-report-environment/4))
+ (r5 (module-environment 'scheme 'scheme-report-environment/5)))
(lambda (n)
(##sys#check-exact n 'scheme-report-environment)
(case n
@@ -1346,8 +1346,8 @@
"unsupported scheme report environment version" n)) ) ) ) )
(define null-environment
- (let ((r4 (##sys#module-environment 'r4rs-null 'null-environment/4))
- (r5 (##sys#module-environment 'r5rs-null 'null-environment/5)))
+ (let ((r4 (module-environment 'r4rs-null 'null-environment/4))
+ (r5 (module-environment 'r5rs-null 'null-environment/5)))
(lambda (n)
(##sys#check-exact n 'null-environment)
(case n
diff --git a/manual/Modules b/manual/Modules
index 37ef8713..4583e40d 100644
--- a/manual/Modules
+++ b/manual/Modules
@@ -236,6 +236,23 @@ macros. Note that these definitions will ruthlessly pollute the
toplevel namespace and so they should be used sparingly.
+=== Using modules as evaluation environments
+
+==== module-environment
+
+<procedure>(module-environment MODULENAME)</procedure>
+
+Locates the module with the name {{MODULENAME}} and returns an
+environment that can be passed as the second argument to {{eval}}. The
+evaluated expressions have only access to the bindings that are
+visible inside the module. Note that the environment is not mutable.
+
+If the module is not registered in the current process, {{module-environment}}
+will try to locate meta-information about the module by loading any
+existing import library with the name {{MODULENAME.import.[scm|so]}},
+if possible.
+
+
=== Predefined modules
Import libraries for the following modules are initially
diff --git a/modules.scm b/modules.scm
index 55e8e0a2..b4dbc423 100644
--- a/modules.scm
+++ b/modules.scm
@@ -396,7 +396,9 @@
sexports))))
(set-module-saved-environments!
mod
- (cons (##sys#current-environment)
+ (cons (merge-se (##sys#current-environment)
+ (module-vexports mod)
+ (module-sexports mod))
(##sys#macro-environment)))
(set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
mod))
@@ -522,7 +524,7 @@
(set-module-sexports! mod sexports)
(set-module-saved-environments!
mod
- (cons (##sys#current-environment)
+ (cons (merge-se (##sys#current-environment) vexports sexports)
(##sys#macro-environment))))))))
(define ##sys#module-table '())
@@ -530,6 +532,28 @@
;;; Import-expansion
+(define (##sys#find-module/import-library mname loc)
+ (let* ((mname (##sys#resolve-module-name mname loc))
+ (mod (##sys#find-module mname #f loc)))
+ (unless mod
+ (let* ((il (##sys#find-extension
+ (string-append (symbol->string mname) ".import")
+ #t)))
+ (cond (il (parameterize ((##sys#current-module #f)
+ (##sys#current-environment '())
+ (##sys#current-meta-environment
+ (##sys#current-meta-environment))
+ (##sys#macro-environment
+ (##sys#meta-macro-environment)))
+ (fluid-let ((##sys#notices-enabled #f)) ; to avoid re-import warnings
+ (##sys#load il #f #f)))
+ (set! mod (##sys#find-module mname 'import)))
+ (else
+ (##sys#syntax-error-hook
+ loc "cannot import from undefined module"
+ mname)))))
+ mod))
+
(define (##sys#expand-import x r c import-env macro-env meta? reexp? loc)
(let ((%only (r 'only))
(%rename (r 'rename))
@@ -545,28 +569,10 @@
((number? x) (number->string x))
(else (##sys#syntax-error-hook loc "invalid prefix" ))))
(define (import-name spec)
- (let* ((mname (##sys#resolve-module-name (##sys#strip-syntax spec) 'import))
- (mod (##sys#find-module mname #f 'import)))
- (unless mod
- (let* ((il (##sys#find-extension
- (string-append (symbol->string mname) ".import")
- #t)))
- (cond (il (parameterize ((##sys#current-module #f)
- (##sys#current-environment '())
- (##sys#current-meta-environment
- (##sys#current-meta-environment))
- (##sys#macro-environment
- (##sys#meta-macro-environment)))
- (fluid-let ((##sys#notices-enabled #f)) ; to avoid re-import warnings
- (##sys#load il #f #f)))
- (set! mod (##sys#find-module mname 'import)))
- (else
- (##sys#syntax-error-hook
- loc "cannot import from undefined module"
- mname)))))
- (let ((vexp (module-vexports mod))
- (sexp (module-sexports mod)))
- (cons vexp sexp))))
+ (let* ((mod (##sys#find-module/import-library (##sys#strip-syntax spec) 'import))
+ (vexp (module-vexports mod))
+ (sexp (module-sexports mod)))
+ (cons vexp sexp)))
(define (import-spec spec)
(cond ((symbol? spec) (import-name spec))
((or (not (list? spec)) (< (length spec) 2))
@@ -851,26 +857,32 @@
with-output-to-file eval
char-ready? imag-part real-part magnitude numerator denominator
scheme-report-environment null-environment interaction-environment
- else)))
- (##sys#register-primitive-module
- 'r4rs
- r4rs-values
- ##sys#default-macro-environment)
+ else))
+ (r4rs-syntax
+ ;;XXX currently disabled - better would be to move these into the "chicken"
+ ;; module. "import[-for-syntax]" and "reexport" are in
+ ;; ##sys#initial-macro-environment and thus always available inside modules.
+ #;(foldr
+ (lambda (s r)
+ (if (memq (car s)
+ '(import require-extension require-library begin-for-syntax
+ export module cond-expand syntax reexport import-for-syntax))
+ r
+ (cons s r)))
+ '()
+ ##sys#default-macro-environment)
+ ##sys#default-macro-environment))
+ (##sys#register-primitive-module 'r4rs r4rs-values r4rs-syntax)
(##sys#register-primitive-module
'scheme
(append '(dynamic-wind values call-with-values) r4rs-values)
- ##sys#default-macro-environment))
-
-(##sys#register-primitive-module 'r4rs-null '() ##sys#default-macro-environment)
-(##sys#register-primitive-module 'r5rs-null '() ##sys#default-macro-environment)
+ r4rs-syntax)
+ (##sys#register-primitive-module 'r4rs-null '() r4rs-syntax)
+ (##sys#register-primitive-module 'r5rs-null '() r4rs-syntax))
(##sys#register-module-alias 'r5rs 'scheme)
-(define (##sys#module-environment mname #!optional (ename mname))
- (let ((mod (##sys#find-module mname)))
- (##sys#make-structure
- 'environment
- ename
- (append
- (module-vexports mod)
- (module-sexports mod)))))
+(define (module-environment mname #!optional (ename mname))
+ (let* ((mod (##sys#find-module/import-library mname 'module-environment))
+ (saved (module-saved-environments mod)))
+ (##sys#make-structure 'environment ename (car saved))))
diff --git a/tests/environment-tests.scm b/tests/environment-tests.scm
index 3735d6f2..517254b2 100644
--- a/tests/environment-tests.scm
+++ b/tests/environment-tests.scm
@@ -26,4 +26,20 @@
(test-error (eval 'car (null-environment 5)))
(test-equal (eval '((lambda (x) x) 123) (null-environment 5)) 123)
+(define baz 100)
+
+(module foo (bar)
+ (import r5rs)
+ (define (bar) 99))
+
+(define foo-env (module-environment 'foo))
+(define srfi-1-env (module-environment 'srfi-1))
+
+(require-library srfi-1)
+
+(test-equal (eval '(bar) foo-env) 99)
+(test-error (eval 'baz foo-env))
+(test-equal (eval '(xcons 1 2) srfi-1-env) '(2 . 1))
+(test-error (eval 'baz srf-1-env))
+
(test-end)
diff --git a/types.db b/types.db
index 1603fda7..f0b6bb64 100644
--- a/types.db
+++ b/types.db
@@ -212,16 +212,19 @@
(dynamic-wind (procedure dynamic-wind (procedure procedure procedure) . *))
(values (procedure values (#!rest values) . *))
(call-with-values (procedure call-with-values (procedure procedure) . *))
-(eval (procedure eval (* #!optional *) *))
+(eval (procedure eval (* #!optional (struct environment)) *))
(char-ready? (procedure char-ready? (#!optional port) boolean))
(imag-part (procedure imag-part (number) number))
(real-part (procedure real-part (number) number))
(magnitude (procedure magnitude (number) number))
(numerator (procedure numerator (number) number))
(denominator (procedure denominator (number) number))
-(scheme-report-environment (procedure scheme-report-environment (#!optional fixnum) *))
-(null-environment (procedure null-environment (#!optional fixnum) *))
-(interaction-environment (procedure interaction-environment () *))
+(scheme-report-environment (procedure scheme-report-environment (#!optional fixnum)
+ (struct environment)))
+(null-environment (procedure null-environment (#!optional fixnum)
+ (struct environment)))
+(interaction-environment (procedure interaction-environment ()
+ (struct environment)))
(port-closed? (procedure port-closed? (port) boolean))
;; chicken
@@ -375,6 +378,7 @@
(maximum-flonum float)
(memory-statistics (procedure memory-statistics () vector))
(minimum-flonum float)
+(module-environment (procedure module-environment (symbol #!optional symbol) (struct environment)))
(most-negative-fixnum fixnum)
(most-positive-fixnum fixnum)
(on-exit (procedure on-exit ((procedure () . *)) undefined))
Trap