~ chicken-core (chicken-5) 48919d6d2928e12c2a2af615ad46c19195257147
commit 48919d6d2928e12c2a2af615ad46c19195257147
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Jul 27 00:50:44 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Jul 27 00:50:44 2011 +0200
use se's in eval-environments - this makes things fully standards-compliant but breaks the environments egg and everything that depends on it
diff --git a/defaults.make b/defaults.make
index 76f8f581..9eddcc82 100644
--- a/defaults.make
+++ b/defaults.make
@@ -298,7 +298,7 @@ CHICKEN_INSTALL_PROGRAM = $(PROGRAM_PREFIX)chicken-install$(PROGRAM_SUFFIX)
CHICKEN_UNINSTALL_PROGRAM = $(PROGRAM_PREFIX)chicken-uninstall$(PROGRAM_SUFFIX)
CHICKEN_STATUS_PROGRAM = $(PROGRAM_PREFIX)chicken-status$(PROGRAM_SUFFIX)
CHICKEN_BUG_PROGRAM = $(PROGRAM_PREFIX)chicken-bug$(PROGRAM_SUFFIX)
-IMPORT_LIBRARIES = chicken lolevel srfi-1 srfi-4 data-structures ports files posix srfi-13 srfi-69 extras srfi-14 tcp foreign scheme srfi-18 utils csi irregex
+IMPORT_LIBRARIES = chicken lolevel srfi-1 srfi-4 data-structures ports files posix srfi-13 srfi-69 extras srfi-14 tcp foreign srfi-18 utils csi irregex
IMPORT_LIBRARIES += setup-api setup-download
SCRUTINIZED_LIBRARIES = library eval data-structures ports files extras lolevel utils tcp srfi-1 srfi-4 srfi-13 srfi-14 srfi-18 srfi-69 $(POSIXFILE) irregex scheduler profiler stub expand modules chicken-syntax chicken-ffi-syntax
diff --git a/distribution/manifest b/distribution/manifest
index 9e69eed3..336e969e 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -100,6 +100,7 @@ build-version.c
buildid
buildtag.h
tests/thread-list.scm
+tests/environment-tests.scm
tests/gobble.scm
tests/test-optional.scm
tests/arithmetic-test.scm
@@ -227,8 +228,6 @@ ports.import.scm
ports.import.c
files.import.scm
files.import.c
-scheme.import.scm
-scheme.import.c
chicken.import.scm
chicken.import.c
foreign.import.scm
diff --git a/eval.scm b/eval.scm
index a7192b87..2b76a14d 100644
--- a/eval.scm
+++ b/eval.scm
@@ -27,9 +27,8 @@
(declare
(unit eval)
- (uses expand)
- (hide ##sys#r4rs-environment ##sys#r5rs-environment
- ##sys#interaction-environment pds pdss pxss d)
+ (uses expand modules)
+ (hide pds pdss pxss d)
(not inline ##sys#repl-read-hook ##sys#repl-print-hook
##sys#read-prompt-hook ##sys#alias-global-hook ##sys#user-read-hook
##sys#syntax-error-hook))
@@ -162,9 +161,6 @@
;;; Compile lambda to closure:
-(define ##sys#eval-environment #f)
-(define ##sys#environment-is-mutable #f)
-
(define (##sys#eval-decorator p ll h cntr)
(##sys#decorate-lambda
p
@@ -179,7 +175,6 @@
p) ) )
(define ##sys#unbound-in-eval #f)
-(define ##sys#unsafe-eval #f)
(define ##sys#eval-debug-level (make-parameter 1))
(define ##sys#compile-to-closure
@@ -188,7 +183,7 @@
[with-input-from-file with-input-from-file]
[unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0)]
[display display] )
- (lambda (exp env se #!optional cntr)
+ (lambda (exp env se #!optional cntr evalenv static)
(define (find-id id se) ; ignores macro bindings
(cond ((null? se) #f)
@@ -239,27 +234,19 @@
(receive (i j) (lookup x e se)
(cond ((not i)
(let ((var (if (not (assq x se))
- (##sys#alias-global-hook j #f cntr)
+ (and (not static)
+ (##sys#alias-global-hook j #f cntr))
(or (##sys#get j '##core#primitive) j))))
- (if ##sys#eval-environment
- (let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)])
- (unless loc
- (##sys#syntax-error-hook "reference to undefined identifier" var))
- (if ##sys#unsafe-eval
- (lambda v (##sys#slot loc 1))
- (lambda v
- (let ([val (##sys#slot loc 1)])
- (if (eq? unbound val)
- (##sys#error "unbound variable" var)
- val) ) ) ))
- (cond (##sys#unsafe-eval
- (lambda v (##core#inline "C_slot" var 0)))
- (else
- (when (and ##sys#unbound-in-eval
- (not (##sys#symbol-has-toplevel-binding? var)))
- (set! ##sys#unbound-in-eval
- (cons (cons var cntr) ##sys#unbound-in-eval)) )
- (lambda v (##core#inline "C_retrieve" var)))))))
+ (when (and ##sys#unbound-in-eval
+ (or (not var)
+ (not (##sys#symbol-has-toplevel-binding? var))))
+ (set! ##sys#unbound-in-eval
+ (cons (cons var cntr) ##sys#unbound-in-eval)) )
+ (cond ((not var)
+ (lambda (v)
+ (##sys#error "unbound variable" x)))
+ (else
+ (lambda v (##core#inline "C_retrieve" var))))))
(else
(case i
((0) (lambda (v)
@@ -365,18 +352,12 @@
(##sys#notice "assignment to imported value binding" var)))
(let ((var
(if (not (assq x se))
- (##sys#alias-global-hook j #t cntr)
+ (and (not static)
+ (##sys#alias-global-hook j #t cntr))
(or (##sys#get j '##core#primitive) j))))
- (if ##sys#eval-environment
- (let ([loc (##sys#hash-table-location
- ##sys#eval-environment
- var
- ##sys#environment-is-mutable) ] )
- (unless loc
- (##sys#error "assignment to undefined identifier" var))
- (if (##sys#slot loc 2)
- (lambda (v) (##sys#setslot loc 1 (##core#app val v)))
- (lambda v (##sys#error "assignment to immutable variable" var)) ) )
+ (if (not var) ; static
+ (lambda (v)
+ (##sys#error 'eval "environment is not mutable" evalenv var))
(lambda (v)
(##sys#setslot var 0 (##core#app val v))) ) ) ]
[(zero? i) (lambda (v) (##sys#setslot (##sys#slot v 0) j (##core#app val v)))]
@@ -394,9 +375,7 @@
(se2 (##sys#extend-se se vars aliases))
[body (##sys#compile-to-closure
(##sys#canonicalize-body (cddr x) se2 #f)
- e2
- se2
- cntr) ] )
+ e2 se2 cntr evalenv static) ] )
(case n
[(1) (let ([val (compile (cadar bindings) e (car vars) tf cntr se)])
(lambda (v)
@@ -469,9 +448,7 @@
(body
(##sys#compile-to-closure
(##sys#canonicalize-body body se2 #f)
- e2
- se2
- (or h cntr) ) ) )
+ e2 se2 (or h cntr) evalenv static) ) )
(case argc
[(0) (if rest
(lambda (v)
@@ -582,6 +559,8 @@
(let* ((var (cadr x))
(body (caddr x))
(name (rename var se)))
+ (when (and static (not (assq var se)))
+ (##sys#error 'eval "environment is not mutable" evalenv var))
(##sys#register-syntax-export
name (##sys#current-module)
body) ; not really necessary, it only shouldn't be #f
@@ -802,7 +781,7 @@
((##sys#compile-to-closure
form
'()
- (##sys#current-meta-environment))
+ (##sys#current-meta-environment)) ;XXX evalenv? static?
'() ) )
(lambda ()
(##sys#active-eval-environment aee)
@@ -812,18 +791,12 @@
(define ##sys#eval-handler
(make-parameter
- (lambda (x . env)
- (let ([mut ##sys#environment-is-mutable]
- [e #f] )
- (when (pair? env)
- (let ([env (car env)])
- (when env
- (##sys#check-structure env 'environment)
- (set! e (##sys#slot env 1))
- (set! mut (##sys#slot env 2)) ) ) )
- ((fluid-let ((##sys#environment-is-mutable mut)
- (##sys#eval-environment e) )
- (##sys#compile-to-closure x '() (##sys#current-environment)) )
+ (lambda (x #!optional env)
+ (let ((se (##sys#current-environment)))
+ (when env
+ (##sys#check-structure env 'environment 'eval)
+ (set! se (or (##sys#slot env 2) se)))
+ ((##sys#compile-to-closure x '() se #f env (and env (##sys#slot env 3)))
'() ) ) ) ) )
(define eval-handler ##sys#eval-handler)
@@ -1350,116 +1323,41 @@
;;; Environments:
-(define ##sys#r4rs-environment (make-vector environment-table-size '()))
-(define ##sys#r5rs-environment #f)
-(define ##sys#interaction-environment (##sys#make-structure 'environment #f #t))
-
-(define (##sys#environment? obj)
- (and (##sys#structure? obj 'environment) (fx= 3 (##sys#size obj))) )
-
-(define ##sys#copy-env-table
- (lambda (e mff mf . args)
- (let ([syms (and (pair? args) (car args))])
- (let* ([s (##sys#size e)]
- [e2 (##sys#make-vector s '())] )
- (do ([i 0 (fx+ i 1)])
- ((fx>= i s) e2)
- (##sys#setslot
- e2 i
- (let copy ([b (##sys#slot e i)])
- (if (null? b)
- '()
- (let ([bi (##sys#slot b 0)])
- (let ([sym (##sys#slot bi 0)])
- (if (or (not syms) (memq sym syms))
- (cons (vector
- sym
- (##sys#slot bi 1)
- (if mff mf (##sys#slot bi 2)))
- (copy (##sys#slot b 1)))
- (copy (##sys#slot b 1)) ) ) ) ) ) ) ) ) ) ) )
-
-(define ##sys#environment-symbols
- (lambda (env . args)
- (##sys#check-structure env 'environment)
- (let ([pred (and (pair? args) (car args))])
- (let ([envtbl (##sys#slot env 1)])
- (if envtbl
- ;then "real" environment
- (let ([envtblsiz (vector-length envtbl)])
- (do ([i 0 (fx+ i 1)]
- [syms
- '()
- (let loop ([bucket (vector-ref envtbl i)] [syms syms])
- (if (null? bucket)
- syms
- (let ([sym (vector-ref (car bucket) 0)])
- (if (or (not pred) (pred sym))
- (loop (cdr bucket) (cons sym syms))
- (loop (cdr bucket) syms) ) ) ) )])
- ((fx>= i envtblsiz) syms) ) )
- ;else interaction-environment
- (let ([syms '()])
- (##sys#walk-namespace
- (lambda (sym)
- (when (or (not pred) (pred sym))
- (set! syms (cons sym syms)) ) ) )
- syms ) ) ) ) ) )
-
-(define (interaction-environment) ##sys#interaction-environment)
+(define interaction-environment
+ (let ((e (##sys#make-structure 'environment 'interaction-environment #f #f)))
+ (lambda () e)))
+
+(define-record-printer (environment e p)
+ (##sys#print "#<environment " #f p)
+ (##sys#print (##sys#slot e 1) #f p)
+ (##sys#write-char-0 #\> p))
(define scheme-report-environment
- (lambda (n . mutable)
- (##sys#check-exact n 'scheme-report-environment)
- (let ([mf (and (pair? mutable) (car mutable))])
+ (let ((r4 (##sys#module-environment 'r4rs 'scheme-report-environment/4))
+ (r5 (##sys#module-environment 'scheme 'scheme-report-environment/5)))
+ (lambda (n)
+ (##sys#check-exact n 'scheme-report-environment)
(case n
- [(4) (##sys#make-structure 'environment (##sys#copy-env-table ##sys#r4rs-environment #t mf) mf)]
- [(5) (##sys#make-structure 'environment (##sys#copy-env-table ##sys#r5rs-environment #t mf) mf)]
- [else (##sys#error 'scheme-report-environment "no support for version" n)] ) ) ) )
+ ((4) r4)
+ ((5) r5)
+ (else
+ (##sys#error
+ 'scheme-report-environment
+ "unsupported scheme report environment version" n)) ) ) ) )
(define null-environment
- (let ([make-vector make-vector])
- (lambda (n . mutable)
+ (let ((r4 (##sys#module-environment 'r4rs-null 'null-environment/4))
+ (r5 (##sys#module-environment 'r5rs-null 'null-environment/5)))
+ (lambda (n)
(##sys#check-exact n 'null-environment)
- (when (or (fx< n 4) (fx> n 5))
- (##sys#error 'null-environment "no support for version" n) )
- (##sys#make-structure
- 'environment
- (make-vector environment-table-size '())
- (and (pair? mutable) (car mutable)) ) ) ) )
-
-(let ()
- (define (initb ht)
- (lambda (b)
- (let ([loc (##sys#hash-table-location ht b #t)])
- (##sys#setslot loc 1 (##sys#slot b 0)) ) ) )
- (for-each
- (initb ##sys#r4rs-environment)
- '(not boolean? eq? eqv? equal? pair? cons car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
- cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr cadddr cdaaar cdaadr cdadar cdaddr
- cddaar cddadr cdddar cddddr set-car! set-cdr! null? list? list length list-tail list-ref
- append reverse memq memv member assq assv assoc symbol? symbol->string string->symbol
- number? integer? exact? real? complex? inexact? rational? zero? odd? even? positive? negative?
- max min + - * / = > < >= <= quotient remainder modulo gcd lcm abs floor ceiling truncate round
- exact->inexact inexact->exact exp log expt sqrt sin cos tan asin acos atan number->string
- string->number char? char=? char>? char<? char>=? char<=? char-ci=? char-ci<? char-ci>?
- char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric? char-upper-case?
- char-lower-case? char-upcase char-downcase char->integer integer->char string? string=?
- string>? string<? string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci>=? string-ci<=?
- make-string string-length string-ref string-set! string-append string-copy string->list
- list->string substring string-fill! vector? make-vector vector-ref vector-set! string vector
- vector-length vector->list list->vector vector-fill! procedure? map for-each apply force
- call-with-current-continuation input-port? output-port? current-input-port current-output-port
- call-with-input-file call-with-output-file open-input-file open-output-file close-input-port
- close-output-port load read eof-object? read-char peek-char
- write display write-char newline with-input-from-file with-output-to-file ##sys#call-with-values
- ##sys#values ##sys#dynamic-wind ##sys#void
- ##sys#list->vector ##sys#list ##sys#append ##sys#cons ##sys#make-promise) )
- (set! ##sys#r5rs-environment (##sys#copy-env-table ##sys#r4rs-environment #t #t))
- (for-each
- (initb ##sys#r5rs-environment)
- '(dynamic-wind values call-with-values eval scheme-report-environment null-environment interaction-environment) ) )
-
+ (case n
+ ((4) r4)
+ ((5) r5)
+ (else
+ (##sys#error
+ 'null-environment
+ "unsupported null environment version" n) )))))
+
;;; Find included file:
diff --git a/expand.scm b/expand.scm
index 9fd21346..8ded474a 100644
--- a/expand.scm
+++ b/expand.scm
@@ -24,9 +24,11 @@
; POSSIBILITY OF SUCH DAMAGE.
+;; this unit needs the "modules" unit, but must be initialized first, so it doesn't
+;; declare "modules" as used - if you use "-explicit-use", take care of this.
+
(declare
(unit expand)
- (uses modules)
(disable-interrupts)
(fixnum)
(hide match-expression
diff --git a/manual/Deviations from the standard b/manual/Deviations from the standard
index ffda509e..f16d5eec 100644
--- a/manual/Deviations from the standard
+++ b/manual/Deviations from the standard
@@ -31,12 +31,6 @@ the procedures {{string->number}}, {{read}}, {{write}}, and {{display}} do not o
read/write invariance to inexact numbers.
-=== Environments and non-standard syntax
-
-Code evaluated in {{scheme-report-environment}} or
-{{null-environment}} still sees non-standard syntax.
-
-
== Unconfirmed deviations
=== {{char-ready?}}
diff --git a/manual/Modules b/manual/Modules
index 6b91f329..37ef8713 100644
--- a/manual/Modules
+++ b/manual/Modules
@@ -28,9 +28,8 @@ import the {{scheme}} module to do anything useful. To access any
of the non-standard macros and procedures, import the {{chicken}}
module.
-CHICKEN's module system has the following features and shortcomings:
+CHICKEN's module system has the following features:
-* Indirect exports for syntax definitions must be listed
* Separation of compile/expansion-time and run-time code is provided, which allows cross compilation
* Module-generating code is only created, when needed
* Supports batch-compilation of separate compilation units
@@ -243,8 +242,11 @@ Import libraries for the following modules are initially
available:
[module] scheme
+ [module] r4rs
+ [module] r5rs
-Exports the standard R5RS bindings.
+Exports the definitions given in R4RS or R5RS. {{r5rs}} is a module alias
+for {{scheme}}.
[module] chicken
diff --git a/manual/The R5RS standard b/manual/The R5RS standard
index f051fdc3..6cc85e1c 100644
--- a/manual/The R5RS standard
+++ b/manual/The R5RS standard
@@ -2830,24 +2830,18 @@ with null-environment or scheme-report-environment.
<procedure>(scheme-report-environment version)</procedure><br>
<procedure>(null-environment version)</procedure><br>
-Version must be the exact integer 5, corresponding to this revision of
-the Scheme report (the Revised^5 Report on Scheme).
-Scheme-report-environment returns a specifier for an environment that
-is empty except for all bindings defined in this report that are either
-required or both optional and supported by the implementation.
-Null-environment returns a specifier for an environment that is empty
-except for the (syntactic) bindings for all syntactic keywords defined
-in this report that are either required or both optional and supported
-by the implementation.
-
-Other values of version can be used to specify environments matching
-past revisions of this report, but their support is not required. An
-implementation will signal an error if version is neither 5 nor another
-value supported by the implementation.
-
-The effect of assigning (through the use of eval) a variable bound in a
-scheme-report-environment (for example car) is unspecified. Thus the
-environments specified by scheme-report-environment may be immutable.
+Version must be either the exact integer 4 or 5, corresponding to the
+respective revisions of the Scheme report (the Revised^N Report on
+Scheme). Scheme-report-environment returns a specifier for an
+environment that is empty except for all bindings defined in this
+report that are either required or both optional and supported by the
+implementation. Null-environment returns a specifier for an
+environment that is empty except for the (syntactic) bindings for all
+syntactic keywords defined in this report that are either required or
+both optional and supported by the implementation.
+
+The environments specified by scheme-report-environment and
+null-environment are immutable.
<procedure>(interaction-environment)</procedure><br>
diff --git a/modules.scm b/modules.scm
index 4e8f2d3d..55e8e0a2 100644
--- a/modules.scm
+++ b/modules.scm
@@ -818,3 +818,59 @@
"in instantiation `" (symbol->string name) "' of functor `"
(symbol->string fname) "', because the following required exports are missing:\n"
(map (lambda (s) (string-append "\n " (symbol->string s))) missing))))))))
+
+
+;;; built-in modules (needed for eval environments)
+
+(let ((r4rs-values
+ '(not boolean? eq? eqv? equal? pair?
+ cons car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr
+ cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar
+ cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr!
+ null? list? list length list-tail list-ref append reverse memq memv
+ member assq assv assoc symbol? symbol->string string->symbol number?
+ integer? exact? real? complex? inexact? rational? zero? odd? even?
+ positive? negative? max min + - * / = > < >= <= quotient remainder
+ modulo gcd lcm abs floor ceiling truncate round exact->inexact
+ inexact->exact exp log expt sqrt sin cos tan asin acos atan
+ number->string string->number char? char=? char>? char<? char>=?
+ char<=? char-ci=? char-ci<? char-ci>? char-ci>=? char-ci<=?
+ char-alphabetic? char-whitespace? char-numeric? char-upper-case?
+ char-lower-case? char-upcase char-downcase char->integer integer->char
+ string? string=? string>? string<? string>=? string<=? string-ci=?
+ string-ci<? string-ci>? string-ci>=? string-ci<=? make-string
+ string-length string-ref string-set! string-append string-copy
+ string->list list->string substring string-fill! vector? make-vector
+ vector-ref vector-set! string vector vector-length vector->list
+ list->vector vector-fill! procedure? map for-each apply force
+ call-with-current-continuation input-port? output-port?
+ current-input-port current-output-port call-with-input-file
+ call-with-output-file open-input-file open-output-file
+ close-input-port close-output-port load read eof-object? read-char
+ peek-char write display write-char newline with-input-from-file
+ 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)
+ (##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)
+
+(##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)))))
diff --git a/scheme.import.scm b/scheme.import.scm
deleted file mode 100644
index 8f14af98..00000000
--- a/scheme.import.scm
+++ /dev/null
@@ -1,58 +0,0 @@
-;;;; scheme.import.scm - import library for "scheme" module
-;
-; Copyright (c) 2008-2011, The Chicken Team
-; All rights reserved.
-;
-; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
-; conditions are met:
-;
-; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
-; Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
-; disclaimer in the documentation and/or other materials provided with the distribution.
-; Neither the name of the author nor the names of its contributors may be used to endorse or promote
-; products derived from this software without specific prior written permission.
-;
-; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
-; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
-; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
-; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-; POSSIBILITY OF SUCH DAMAGE.
-
-
-(##sys#register-primitive-module
- 'scheme
- '(not boolean? eq? eqv? equal? pair?
- cons car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr
- cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar
- cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr!
- null? list? list length list-tail list-ref append reverse memq memv
- member assq assv assoc symbol? symbol->string string->symbol number?
- integer? exact? real? complex? inexact? rational? zero? odd? even?
- positive? negative? max min + - * / = > < >= <= quotient remainder
- modulo gcd lcm abs floor ceiling truncate round exact->inexact
- inexact->exact exp log expt sqrt sin cos tan asin acos atan
- number->string string->number char? char=? char>? char<? char>=?
- char<=? char-ci=? char-ci<? char-ci>? char-ci>=? char-ci<=?
- char-alphabetic? char-whitespace? char-numeric? char-upper-case?
- char-lower-case? char-upcase char-downcase char->integer integer->char
- string? string=? string>? string<? string>=? string<=? string-ci=?
- string-ci<? string-ci>? string-ci>=? string-ci<=? make-string
- string-length string-ref string-set! string-append string-copy
- string->list list->string substring string-fill! vector? make-vector
- vector-ref vector-set! string vector vector-length vector->list
- list->vector vector-fill! procedure? map for-each apply force
- call-with-current-continuation input-port? output-port?
- current-input-port current-output-port call-with-input-file
- call-with-output-file open-input-file open-output-file
- close-input-port close-output-port load read eof-object? read-char
- peek-char write display write-char newline with-input-from-file
- with-output-to-file dynamic-wind values call-with-values eval
- char-ready? imag-part real-part magnitude numerator denominator
- scheme-report-environment null-environment interaction-environment
- else)
- ##sys#default-macro-environment)
diff --git a/tests/environment-tests.scm b/tests/environment-tests.scm
new file mode 100644
index 00000000..3735d6f2
--- /dev/null
+++ b/tests/environment-tests.scm
@@ -0,0 +1,29 @@
+;;;; environment-tests.scm
+
+
+(load-relative "test.scm")
+
+
+(test-begin "evaluation environment tests")
+
+(test-equal (eval 123) 123)
+(test-equal (eval 123 (interaction-environment)) 123)
+(test-equal (eval 'car (interaction-environment)) car)
+(test-error (eval 'foo (interaction-environment)))
+(test-equal (eval '(begin (set! foo 99) foo) (interaction-environment)) 99)
+
+(test-equal (eval 123) 123)
+(test-equal (eval 123 (scheme-report-environment 5)) 123)
+(test-equal (eval 'car (scheme-report-environment 5)) car)
+(test-error (eval 'foo (scheme-report-environment 5)))
+(test-error (eval 'values (scheme-report-environment 4)))
+(test-equal (eval 'values (scheme-report-environment 5)) values)
+(test-error (eval '(set! foo 99) (scheme-report-environment 5)))
+
+(test-error (eval '(define-syntax foo (syntax-rules () ((_) 1)))
+ (scheme-report-environment 5)))
+
+(test-error (eval 'car (null-environment 5)))
+(test-equal (eval '((lambda (x) x) 123) (null-environment 5)) 123)
+
+(test-end)
diff --git a/tests/reexport-tests.scm b/tests/reexport-tests.scm
index ff0fb14f..892ad643 100644
--- a/tests/reexport-tests.scm
+++ b/tests/reexport-tests.scm
@@ -1,7 +1,7 @@
;;;; reexport-tests.scm
-(module r4rs ()
+(module my-r4rs ()
(import scheme chicken)
(reexport
(except scheme
@@ -9,7 +9,7 @@
null-environment interaction-environment)))
(module m1 ()
- (import r4rs)
+ (import my-r4rs)
(display (+ 3 4))
(newline))
@@ -17,7 +17,7 @@
(not
(handle-exceptions ex #f
(eval '(module m2 ()
- (import r4rs)
+ (import my-r4rs)
(values 123))))))
(define-syntax compound-module
diff --git a/tests/runtests.sh b/tests/runtests.sh
index ae364544..fb17445a 100644
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -21,7 +21,7 @@ for x in setup-api.so setup-api.import.so setup-download.so \
ports.import.so files.import.so posix.import.so \
srfi-13.import.so srfi-69.import.so extras.import.so \
irregex.import.so srfi-14.import.so tcp.import.so \
- foreign.import.so scheme.import.so srfi-18.import.so \
+ foreign.import.so srfi-18.import.so \
utils.import.so csi.import.so irregex.import.so types.db; do
cp ../$x test-repository
done
@@ -123,6 +123,9 @@ fi
echo "======================================== pretty-printer tests ..."
$interpret -s pp-test.scm
+echo "======================================== evaluation environment tests ..."
+$interpret -s environment-tests.scm
+
echo "======================================== syntax tests ..."
$interpret -s syntax-tests.scm
Trap