even better

svn: r13341

collects/tests/mzscheme/sandbox.ss

@@ -36,6 +36,14 @@
   (test 'shut (lambda () (nested* (shut)))))
 
 (let ([ev void])
+  (define (make-evaluator! . args)
+    (set! ev (apply make-evaluator args)))
+  (define (make-base-evaluator! . args)
+    (set! ev (apply make-evaluator 'scheme/base args)))
+  (define (make-base-evaluator/reqs! reqs . args)
+    (set! ev (apply make-evaluator 'scheme/base #:requires reqs args)))
+  (define (make-module-evaluator! . args)
+    (set! ev (apply make-module-evaluator args)))
   (define (run thunk)
     (with-handlers ([void (lambda (e) (list 'exn: e))])
       (call-with-values thunk (lambda vs (cons 'vals: vs)))))
@@ -74,12 +82,12 @@
 
    ;; basic stuff, limits
    --top--
-   (set! ev (make-evaluator 'scheme/base
-              (make-prog "(define x 1)"
-                         "(define (id x) x)"
-                         "(define (plus1 x) x)"
-                         "(define (loop) (loop))"
-                         "(define (memory x) (make-vector x))")))
+   (make-base-evaluator!
+    (make-prog "(define x 1)"
+               "(define (id x) x)"
+               "(define (plus1 x) x)"
+               "(define (loop) (loop))"
+               "(define (memory x) (make-vector x))"))
    (set-eval-limits ev 0.5 5)
    --eval--
    x => 1
@@ -138,29 +146,28 @@
    ,eof =err> "terminated .eof.$"
 
    ;; other termination messages
-   --top-- (set! ev (make-evaluator 'scheme/base)) (kill-evaluator ev)
+   --top-- (make-base-evaluator!) (kill-evaluator ev)
    --eval-- 123 =err> "terminated .evaluator-killed.$"
 
    ;; eval-limits apply to the sandbox creation too
    --top--
-   (set! ev (parameterize ([sandbox-eval-limits '(0.25 5)])
-              (make-evaluator 'scheme/base '(sleep 2))))
+   (parameterize ([sandbox-eval-limits '(0.25 5)])
+     (make-base-evaluator! '(sleep 2)))
    =err> "out of time"
    (when (custodian-memory-accounting-available?)
      (t --top--
-        (set! ev (parameterize ([sandbox-eval-limits '(2 2)])
-                   (make-evaluator 'scheme/base
-                                   '(define a (for/list ([i (in-range 10)])
-                                                (collect-garbage)
-                                                (make-bytes 500000))))))
+        (parameterize ([sandbox-eval-limits '(2 2)])
+          (make-base-evaluator! '(define a (for/list ([i (in-range 10)])
+                                             (collect-garbage)
+                                             (make-bytes 500000)))))
         =err> "out of memor(?:y)"))
 
    ;; i/o
    --top--
-   (set! ev (parameterize ([sandbox-input "3\n"]
-                           [sandbox-output 'string]
-                           [sandbox-error-output current-output-port])
-              (make-evaluator 'scheme/base '(define x 123))))
+   (parameterize ([sandbox-input "3\n"]
+                  [sandbox-output 'string]
+                  [sandbox-error-output current-output-port])
+     (make-base-evaluator! '(define x 123)))
    --eval-- (printf "x = ~s\n" x) => (void)
    --top--  (get-output ev) => "x = 123\n"
    --eval-- (printf "x = ~s\n" x) => (void)
@@ -174,18 +181,17 @@
    --top--  (get-output ev) => "a\nb\n"
             (get-error-output ev) => #f
    --top--
-   (set! ev (parameterize ([sandbox-output 'string]
-                           [sandbox-error-output 'string])
-              (make-evaluator 'scheme/base)))
+   (parameterize ([sandbox-output 'string] [sandbox-error-output 'string])
+     (make-base-evaluator!))
    --eval-- (begin (printf "a\n") (fprintf (current-error-port) "b\n"))
    --top--  (get-output ev) => "a\n"
             (get-error-output ev) => "b\n"
    --top--
-   (set! ev (parameterize ([sandbox-input 'pipe]
-                           [sandbox-output 'bytes]
-                           [sandbox-error-output current-output-port]
-                           [sandbox-eval-limits '(0.25 10)])
-              (make-evaluator 'scheme/base '(define x 123))))
+   (parameterize ([sandbox-input 'pipe]
+                  [sandbox-output 'bytes]
+                  [sandbox-error-output current-output-port]
+                  [sandbox-eval-limits '(0.25 10)])
+     (make-base-evaluator! '(define x 123)))
    --eval--  (begin (printf "x = ~s\n" x)
                     (fprintf (current-error-port) "err\n"))
    --top--   (get-output ev) => #"x = 123\nerr\n"
@@ -210,8 +216,8 @@
    --top--
    (let-values ([(i1 o1) (make-pipe)] [(i2 o2) (make-pipe)])
      ;; o1 -> i1 -ev-> o2 -> i2
-     (set! ev (parameterize ([sandbox-input i1] [sandbox-output o2])
-                (make-evaluator 'scheme/base '(define x 123))))
+     (parameterize ([sandbox-input i1] [sandbox-output o2])
+       (make-base-evaluator! '(define x 123)))
      (t --eval-- (printf "x = ~s\n" x) => (void)
         --top--  (read-line i2) => "x = 123"
         --eval-- (printf "x = ~s\n" x) => (void)
@@ -227,48 +233,46 @@
 
    ;; sexprs as a program
    --top--
-   (set! ev (make-evaluator 'scheme/base '(define id (lambda (x) x))))
+   (make-base-evaluator! '(define id (lambda (x) x)))
    --eval--
    (id 123) => 123
    --top--
-   (set! ev (make-evaluator 'scheme/base '(define id (lambda (x) x))
-                                         '(define fooo 999)))
+   (make-base-evaluator! '(define id (lambda (x) x)) '(define fooo 999))
    --eval--
    (id fooo) => 999
 
    ;; test source locations too
    --top--
-   (make-evaluator 'scheme/base 0 1 2 '(define foo))
-     =err> "program:4:0: define"
+   (make-base-evaluator! 0 1 2 '(define foo))
+   =err> "program:4:0: define"
 
    ;; empty program for clean repls
    --top--
-   (set! ev (make-evaluator '(begin)))
+   (make-evaluator! '(begin))
    --eval--
    (define x (+ 1 2 3)) => (void)
    x => 6
    (define x (+ x 10)) => (void)
    x => 16
    --top--
-   (set! ev (make-evaluator 'scheme/base))
+   (make-base-evaluator!)
    --eval--
    (define x (+ 1 2 3)) => (void)
    x => 6
    (define x (+ x 10)) => (void)
    x => 16
    --top--
-   (set! ev (make-evaluator 'scheme/base '(define x (+ 1 2 3))))
+   (make-base-evaluator! '(define x (+ 1 2 3)))
    --eval--
    (define x (+ x 10)) =err> "cannot re-define a constant"
 
    ;; whole program argument
    --top--
-   (set! ev (make-module-evaluator '(module foo scheme/base (define x 1))))
+   (make-module-evaluator! '(module foo scheme/base (define x 1)))
    --eval--
    x => 1
    --top--
-   (set! ev (make-module-evaluator
-             '(module foo scheme/base (provide x) (define x 1))))
+   (make-module-evaluator! '(module foo scheme/base (provide x) (define x 1)))
    --eval--
    x => 1
    (define x 2) =err> "cannot re-define a constant"
@@ -285,7 +289,7 @@
           [test2-lib (strpath tmp "sandbox-test2.ss")]
           [test2-zo  (strpath tmp "compiled" "sandbox-test2_ss.zo")])
      (t --top--
-        (set! ev (make-evaluator 'scheme/base))
+        (make-base-evaluator!)
         --eval--
         ;; reading from collects is allowed
         (list? (directory-list ,schemelib))
@@ -304,7 +308,7 @@
           (lambda ()
             (printf "~s\n" '(module sandbox-test scheme/base
                               (define x 123) (provide x)))))
-        (set! ev (make-evaluator 'scheme/base #:requires `(,test-lib)))
+        (make-base-evaluator/reqs! `(,test-lib))
         --eval--
         x => 123
         (length (with-input-from-file ,test-lib read)) => 5
@@ -313,8 +317,8 @@
         --top--
         ;; should work also for module evaluators
         ;; --> NO!  Shouldn't make user code require whatever it wants
-        ;; (set! ev (make-evaluator `(module foo scheme/base
-        ;;                             (require (file ,test-lib)))))
+        ;; (make-module-evaluator!
+        ;;   `(module foo scheme/base (require (file ,test-lib))))
         ;; --eval--
         ;; x => 123
         ;; (length (with-input-from-file ,test-lib read)) => 5
@@ -323,11 +327,10 @@
         --top--
         ;; explicitly allow access to tmp, and write access to a single file
         (make-directory (build-path tmp "compiled"))
-        (set! ev (parameterize ([sandbox-path-permissions
-                                 `((read ,tmp)
-                                   (write ,test-zo)
-                                   ,@(sandbox-path-permissions))])
-                   (make-evaluator 'scheme/base)))
+        (parameterize ([sandbox-path-permissions
+                        `((read ,tmp) (write ,test-zo)
+                          ,@(sandbox-path-permissions))])
+          (make-base-evaluator!))
         --eval--
         (length (with-input-from-file ,test-lib read)) => 5
         (list? (directory-list ,tmp))
@@ -345,11 +348,10 @@
         --top--
         ;; a more explicit test of bytcode loading, allowing rw access to the
         ;; complete tmp directory, but read-bytecode only for test2-lib
-        (set! ev (parameterize ([sandbox-path-permissions
-                                 `((write ,tmp)
-                                   (read-bytecode ,test2-lib)
-                                   ,@(sandbox-path-permissions))])
-                   (make-evaluator 'scheme/base)))
+        (parameterize ([sandbox-path-permissions
+                        `((write ,tmp) (read-bytecode ,test2-lib)
+                          ,@(sandbox-path-permissions))])
+          (make-base-evaluator!))
         --eval--
         (define (cp from to)
           (when (file-exists? to) (delete-file to))
@@ -366,35 +368,35 @@
 
    ;; languages and requires
    --top--
-   (set! ev (make-evaluator '(special r5rs) "(define x (eq? 'x 'X))"))
+   (make-evaluator! '(special r5rs) "(define x (eq? 'x 'X))")
    --eval--
    x => #t
    --top--
-   (set! ev (make-evaluator 'scheme/base "(define l null)"))
+   (make-base-evaluator! "(define l null)")
    --eval--
    (cond [null? l 0]) => 0
    (last-pair l) =err> "reference to an identifier"
    --top--
-   (set! ev (make-evaluator '(special beginner)
-                            (make-prog "(define l null)" "(define x 3.5)")))
+   (make-evaluator! '(special beginner)
+                    (make-prog "(define l null)" "(define x 3.5)"))
    --eval--
    (cond [null? l 0]) =err> "expected an open parenthesis"
    --top--
    (eq? (ev "6") (ev "(sub1 (* 2 3.5))"))
    (eq? (ev "6") (ev "(sub1 (* 2 x))"))
    --top--
-   (set! ev (make-evaluator 'scheme/base #:requires '(scheme/list)))
+   (make-base-evaluator/reqs! '(scheme/list))
    --eval--
    (last-pair '(1 2 3)) => '(3)
    (last-pair null) =err> "expected argument of type"
 
    ;; coverage
    --top--
-   (set! ev (parameterize ([sandbox-coverage-enabled #t])
-              (make-evaluator 'scheme/base
-                              (make-prog "(define (foo x) (+ x 1))"
-                                         "(define (bar x) (+ x 2))"
-                                         "(equal? (foo 3) 4)"))))
+   (parameterize ([sandbox-coverage-enabled #t])
+     (make-base-evaluator!
+      (make-prog "(define (foo x) (+ x 1))"
+                 "(define (bar x) (+ x 2))"
+                 "(equal? (foo 3) 4)")))
    (pair? (get-uncovered-expressions ev))
    (pair? (get-uncovered-expressions ev #t))
    --eval--
@@ -406,13 +408,13 @@
 
    ;; misc parameters
    --top--
-   (set! ev (parameterize ([sandbox-init-hook
-                            (let ([old (sandbox-init-hook)])
-                              (lambda ()
-                                (old)
-                                (compile-enforce-module-constants #f)
-                                (compile-allow-set!-undefined #t)))])
-              (make-evaluator 'scheme/base '(define x 123))))
+   (parameterize ([sandbox-init-hook
+                   (let ([old (sandbox-init-hook)])
+                     (lambda ()
+                       (old)
+                       (compile-enforce-module-constants #f)
+                       (compile-allow-set!-undefined #t)))])
+     (make-base-evaluator! '(define x 123)))
    --eval--
    (set! x 456) ; would be an error without the `enforce' parameter
    x => 456
@@ -421,11 +423,11 @@
 
    ;; test that output is also collected under the limit
    --top--
-   (set! ev (parameterize ([sandbox-output 'bytes]
-                           [sandbox-error-output current-output-port]
-                           [sandbox-memory-limit 2]
-                           [sandbox-eval-limits '(0.25 1)])
-              (make-evaluator 'scheme/base)))
+   (parameterize ([sandbox-output 'bytes]
+                  [sandbox-error-output current-output-port]
+                  [sandbox-memory-limit 2]
+                  [sandbox-eval-limits '(0.25 1)])
+     (make-base-evaluator!))
    ;; GCing is needed to allow these to happen (note: the memory limit is very
    ;; tight here, this test usually fails if the sandbox library is not
    ;; compiled)
@@ -440,26 +442,25 @@
    ;; thread/custodian)
    --top--
    (let ()
-     (define (make!) (set! ev (make-evaluator 'scheme/base)))
      (define (3x2-terminations)
-       (t --top-- (make!) --eval--
+       (t --top-- (make-base-evaluator!) --eval--
           (kill-thread (current-thread)) =err> "terminated .thread-killed.$"
-          --top-- (make!) --eval--
+          --top-- (make-base-evaluator!) --eval--
           (custodian-shutdown-all (current-custodian))
           =err> "terminated .custodian-shutdown.$"
-          --top-- (make!) --eval--
+          --top-- (make-base-evaluator!) --eval--
           (exit) =err> "terminated .exited.$"
           ;; now test that it's fine when called directly
           --top--
-          (make!)
+          (make-base-evaluator!)
           (call-in-sandbox-context ev
             (lambda () (kill-thread (current-thread))))
           =err> "terminated .thread-killed.$"
-          (make!)
+          (make-base-evaluator!)
           (call-in-sandbox-context ev
             (lambda () (custodian-shutdown-all (current-custodian))))
           =err> "terminated .custodian-shutdown.$"
-          (make!)
+          (make-base-evaluator!)
           (call-in-sandbox-context ev exit) =err> "terminated .exited.$"))
      (define (test-terminations)
        ;; try without, then with per-expression limits
@@ -471,9 +472,9 @@
    --top--
    (when (custodian-memory-accounting-available?)
      (t --top--
-        (set! ev (parameterize ([sandbox-eval-limits '(2 5)]
-                                [sandbox-memory-limit 100])
-                   (make-evaluator 'scheme/base)))
+        (parameterize ([sandbox-eval-limits '(2 5)]
+                       [sandbox-memory-limit 100])
+          (make-base-evaluator!))
         --eval--
         (define a '())
         (define b 1)