suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

switch to #lang, reformat

Browse Source 
svn: r12655
This commit is contained in:
Eli Barzilay 2008-12-01 03:21:46 +00:00
parent 8905cc86e5
commit 7ea8ab6592
1 changed files with 113 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

232
collects/mzlib/sandbox.ss
View File

@ -1,124 +1,118 @@
(module sandbox scheme/base #lang scheme/base
(require scheme/sandbox
(prefix-in mz: (only-in mzscheme make-namespace)))
(provide sandbox-init-hook
sandbox-reader
sandbox-input
sandbox-output
sandbox-error-output
sandbox-propagate-breaks
sandbox-coverage-enabled
sandbox-namespace-specs
sandbox-override-collection-paths
sandbox-security-guard
sandbox-path-permissions
sandbox-network-guard
sandbox-make-inspector
sandbox-eval-limits
kill-evaluator
break-evaluator
set-eval-limits
put-input
get-output
get-error-output
get-uncovered-expressions
call-with-limits
with-limits
exn:fail:resource?
exn:fail:resource-resource
(rename-out [*make-evaluator make-evaluator]
[gui? mred?]))
(define-namespace-anchor anchor) (require scheme/sandbox
(prefix-in mz: (only-in mzscheme make-namespace)))
;; Compatbility: (provide sandbox-init-hook
;; * recognize 'r5rs, etc, and wrap them as a list. sandbox-reader
;; * 'begin form of reqs sandbox-input
;; * more agressively extract requires from lang and reqs sandbox-output
(define *make-evaluator sandbox-error-output
(case-lambda sandbox-propagate-breaks
[(lang reqs . progs) sandbox-coverage-enabled
(with-ns-params sandbox-namespace-specs
(lambda () sandbox-override-collection-paths
(let ([beg-req? (and (list? reqs) sandbox-security-guard
(pair? reqs) sandbox-path-permissions
(eq? 'begin (car reqs)))] sandbox-network-guard
[reqs (or reqs '())] sandbox-make-inspector
[lang (or lang '(begin))]) sandbox-eval-limits
(keyword-apply kill-evaluator
make-evaluator break-evaluator
'(#:allow-read #:requires) set-eval-limits
(list (extract-requires lang reqs) put-input
(if beg-req? null reqs)) get-output
(case lang get-error-output
[(r5rs beginner beginner-abbr intermediate intermediate-lambda advanced) get-uncovered-expressions
(list 'special lang)] call-with-limits
[else lang]) with-limits
(append exn:fail:resource?
(if beg-req? (cdr reqs) null) exn:fail:resource-resource
progs)))))] (rename-out [*make-evaluator make-evaluator]
[(mod) [gui? mred?]))
(with-ns-params
(lambda ()
(make-module-evaluator mod)))]))
(define (make-mz-namespace) (define-namespace-anchor anchor)
(let ([ns (mz:make-namespace)])
;; Because scheme/sandbox needs scheme/base:
(namespace-attach-module (namespace-anchor->namespace anchor)
'scheme/base
ns)
ns))
(define (with-ns-params thunk) ;; Compatbility:
(let ([v (sandbox-namespace-specs)]) ;; * recognize 'r5rs, etc, and wrap them as a list.
(cond ;; * 'begin form of reqs
[(and (not gui?) ;; * more agressively extract requires from lang and reqs
(eq? (car v) make-base-namespace)) (define *make-evaluator
(parameterize ([sandbox-namespace-specs (case-lambda
(cons make-mz-namespace [(lang reqs . progs)
(cdr v))]) (with-ns-params
(thunk))] (lambda ()
[(and gui? (let ([beg-req? (and (list? reqs)
(eq? (car v) (dynamic-require 'mred 'make-gui-namespace))) (pair? reqs)
(parameterize ([sandbox-namespace-specs (eq? 'begin (car reqs)))]
;; Simulate the old make-namespace-with-mred: [reqs (or reqs '())]
(cons (lambda () [lang (or lang '(begin))])
(let ([ns (make-mz-namespace)] (keyword-apply
[ns2 ((dynamic-require 'mred 'make-gui-namespace))]) make-evaluator
(namespace-attach-module ns2 'mred ns) '(#:allow-read #:requires)
(namespace-attach-module ns2 'scheme/class ns) (list (extract-requires lang reqs)
(parameterize ([current-namespace ns]) (if beg-req? null reqs))
(namespace-require 'mred) (case lang
(namespace-require 'scheme/class)) [(r5rs beginner beginner-abbr intermediate intermediate-lambda
ns)) advanced)
(cdr v))]) (list 'special lang)]
(thunk))] [else lang])
[else (thunk)]))) (append (if beg-req? (cdr reqs) null) progs)))))]
[(mod) (with-ns-params (lambda () (make-module-evaluator mod)))]))
(define (literal-identifier=? x y)
(or (free-identifier=? x y)
(eq? (syntax-e x) (syntax-e y))))
(define (extract-requires language requires) (define (make-mz-namespace)
(define (find-requires forms) (let ([ns (mz:make-namespace)])
(let loop ([forms (reverse forms)] [reqs '()]) ;; Because scheme/sandbox needs scheme/base:
(if (null? forms) (namespace-attach-module (namespace-anchor->namespace anchor)
reqs 'scheme/base ns)
(loop (cdr forms) ns))
(syntax-case* (car forms) (require) literal-identifier=?
[(require specs ...) (define (with-ns-params thunk)
(append (syntax->datum #'(specs ...)) reqs)] (let ([v (sandbox-namespace-specs)])
[_else reqs]))))) (cond [(and (not gui?) (eq? (car v) make-base-namespace))
(let* ([requires (if (and (pair? requires) (eq? 'begin (car requires))) (parameterize ([sandbox-namespace-specs
(find-requires (cdr requires)) (cons make-mz-namespace (cdr v))])
null)] (thunk))]
[requires (cond [(string? language) requires] [(and gui? (eq? (car v) (dynamic-require 'mred 'make-gui-namespace)))
[(not (pair? language)) requires] (parameterize
[(memq (car language) '(lib file planet quote)) ([sandbox-namespace-specs
requires] ;; Simulate the old make-namespace-with-mred:
[(eq? (car language) 'begin) (cons (lambda ()
(append (find-requires (cdr language)) requires)] (let ([ns (make-mz-namespace)]
[else (error 'extract-requires [ns2 ((dynamic-require
"bad language spec: ~e" language)])]) 'mred 'make-gui-namespace))])
requires))) (namespace-attach-module ns2 'mred ns)
(namespace-attach-module ns2 'scheme/class ns)
(parameterize ([current-namespace ns])
(namespace-require 'mred)
(namespace-require 'scheme/class))
ns))
(cdr v))])
(thunk))]
[else (thunk)])))
(define (literal-identifier=? x y)
(or (free-identifier=? x y) (eq? (syntax-e x) (syntax-e y))))
(define (extract-requires language requires)
(define (find-requires forms)
(let loop ([forms (reverse forms)] [reqs '()])
(if (null? forms)
reqs
(loop (cdr forms)
(syntax-case* (car forms) (require) literal-identifier=?
[(require specs ...)
(append (syntax->datum #'(specs ...)) reqs)]
[_else reqs])))))
(let* ([requires (if (and (pair? requires) (eq? 'begin (car requires)))
(find-requires (cdr requires))
null)]
[requires (cond [(string? language) requires]
[(not (pair? language)) requires]
[(memq (car language) '(lib file planet quote))
requires]
[(eq? (car language) 'begin)
(append (find-requires (cdr language)) requires)]
[else (error 'extract-requires
"bad language spec: ~e" language)])])
requires))