From 36c56848768a7d531f3f7467c200544f33639fec Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 19 Dec 2007 04:12:02 +0000 Subject: [PATCH] put mzlib test suites into separate sandboxes svn: r8058 --- .../tests/mzscheme/contract-mzlib-test.ss | 3 +- collects/tests/mzscheme/macrolib.ss | 2 +- collects/tests/mzscheme/mzlib.ss | 52 +++++++++---------- collects/tests/mzscheme/testing.ss | 20 +++++++ src/mzscheme/src/stxobj.c | 2 - 5 files changed, 47 insertions(+), 32 deletions(-) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index 97f2f884ab..05072f0d1d 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -18,7 +18,8 @@ of the contract library does not change over time. (namespace-require '(for-syntax mzscheme)) (namespace-require '(for-template mzscheme)) (namespace-require 'mzlib/contract) - (namespace-require 'mzlib/class)) + (namespace-require 'mzlib/class) + (namespace-require '(only mzscheme force delay))) n)) (define (contract-eval x) diff --git a/collects/tests/mzscheme/macrolib.ss b/collects/tests/mzscheme/macrolib.ss index 67cababc97..bf01afe12c 100644 --- a/collects/tests/mzscheme/macrolib.ss +++ b/collects/tests/mzscheme/macrolib.ss @@ -66,7 +66,7 @@ (syntax-test #'(let ([define-values 10]) (local ((define-values (x) 4)) 10))) (syntax-test #'(let ([define-struct 10]) (local ((define-struct x ())) 10))) -(define else #f) ;; `evcase' needs unbound `else' !!!! <------------------ WARNING +(define else #t) ;; `evcase' needs unbound `else' !!!! <------------------ WARNING (for-each syntax-test (list #'(evcase) diff --git a/collects/tests/mzscheme/mzlib.ss b/collects/tests/mzscheme/mzlib.ss index 1bef62637d..297bcb00b8 100644 --- a/collects/tests/mzscheme/mzlib.ss +++ b/collects/tests/mzscheme/mzlib.ss @@ -4,56 +4,52 @@ (load-relative "loadtest.ss") -(load-relative "md5.ss") +(load-in-sandbox "md5.ss") -(load-relative "etc.ss") +(load-in-sandbox "etc.ss") -(load-relative "structlib.ss") +(load-in-sandbox "structlib.ss") -(load-relative "async-channel.ss") +(load-in-sandbox "async-channel.ss") -(load-relative "restart.ss") +(load-in-sandbox "restart.ss") -(load-relative "function.ss") +(load-in-sandbox "function.ss") -(load-relative "string.ss") +(load-in-sandbox "string.ss") -(load-relative "filelib.ss") +(load-in-sandbox "filelib.ss") -(load-relative "portlib.ss") +(load-in-sandbox "portlib.ss") -(load-relative "threadlib.ss") +(load-in-sandbox "threadlib.ss") -(load-relative "date.ss") +(load-in-sandbox "date.ss") -(load-relative "compat.ss") +(load-in-sandbox "compat.ss") -(load-relative "cmdline.ss") +(load-in-sandbox "cmdline.ss") -(load-relative "pconvert.ss") +(load-in-sandbox "pconvert.ss") -(load-relative "pretty.ss") +(load-in-sandbox "pretty.ss") -(load-relative "control.ss") +(load-in-sandbox "control.ss") -;; (load-relative "package.ss") +;; (load-in-sandbox "package.ss") -(load-relative "contract-test.ss") ;; tests scheme/contract +(load-in-sandbox "contract-test.ss") ;; tests scheme/contract -(load-relative "contract-mzlib-test.ss") ;; tests mzlib/contract +(load-in-sandbox "contract-mzlib-test.ss") ;; tests mzlib/contract -(load-relative "match-test.ss") +(load-in-sandbox "match-test.ss") -(load-relative "sandbox.ss") +(load-in-sandbox "sandbox.ss") -; Near last, because it `require's mzscheme: -; (load-relative "shared.ss") - FIXME +; (load-in-sandbox "shared.ss") - FIXME -; Also `require's mzscheme: -(load-relative "kw.ss") +(load-in-sandbox "kw.ss") -; Last - so macros are not present by accident -; Also: currently re-defines `else'! -(load-relative "macrolib.ss") +(load-in-sandbox "macrolib.ss") (report-errs) diff --git a/collects/tests/mzscheme/testing.ss b/collects/tests/mzscheme/testing.ss index dfada9d5df..e4918a1979 100644 --- a/collects/tests/mzscheme/testing.ss +++ b/collects/tests/mzscheme/testing.ss @@ -76,6 +76,26 @@ transcript. (define number-of-error-tests 0) (define number-of-exn-tests 0) +(define (load-in-sandbox file) + (let ([e (parameterize ([(dynamic-require 'scheme/sandbox 'sandbox-security-guard) + (current-security-guard)] + [(dynamic-require 'scheme/sandbox 'sandbox-input) + current-input-port] + [(dynamic-require 'scheme/sandbox 'sandbox-output) + current-output-port] + [(dynamic-require 'scheme/sandbox 'sandbox-error-output) + current-error-port]) + ((dynamic-require 'scheme/sandbox 'make-evaluator) '(begin) #:requires (list 'scheme)))]) + (e `(load-relative (quote ,file))) + (let ([l (e '(list number-of-tests + number-of-error-tests + number-of-exn-tests + errs))]) + (set! number-of-tests (+ number-of-tests (list-ref l 0))) + (set! number-of-error-tests (+ number-of-error-tests (list-ref l 1))) + (set! number-of-exn-tests (+ number-of-exn-tests (list-ref l 2))) + (set! errs (append (list-ref l 3) errs))))) + (define (test expect fun . args) (set! number-of-tests (add1 number-of-tests)) (printf "~s ==> " (cons fun args)) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index d001b438ac..ed5fefe2dc 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -65,8 +65,6 @@ static Scheme_Object *module_binding(int argc, Scheme_Object **argv); static Scheme_Object *module_trans_binding(int argc, Scheme_Object **argv); static Scheme_Object *module_templ_binding(int argc, Scheme_Object **argv); static Scheme_Object *module_label_binding(int argc, Scheme_Object **argv); -static Scheme_Object *module_binding_pos(int argc, Scheme_Object **argv); -static Scheme_Object *module_trans_binding_pos(int argc, Scheme_Object **argv); static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv); static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv);