switch to #lang, reformat
svn: r12655 original commit: 7ea8ab6592e4ea96121d24c3b3fa4ed355e653cd
This commit is contained in:
Eli Barzilay
parent
510305451c
commit
75308c9158
|
|
@ -1,124 +1,118 @@
|
|||
(module sandbox 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?]))
|
||||
#lang scheme/base
|
||||
|
||||
(define-namespace-anchor anchor)
|
||||
(require scheme/sandbox
|
||||
(prefix-in mz: (only-in mzscheme make-namespace)))
|
||||
|
||||
;; Compatbility:
|
||||
;; * recognize 'r5rs, etc, and wrap them as a list.
|
||||
;; * 'begin form of reqs
|
||||
;; * more agressively extract requires from lang and reqs
|
||||
(define *make-evaluator
|
||||
(case-lambda
|
||||
[(lang reqs . progs)
|
||||
(with-ns-params
|
||||
(lambda ()
|
||||
(let ([beg-req? (and (list? reqs)
|
||||
(pair? reqs)
|
||||
(eq? 'begin (car reqs)))]
|
||||
[reqs (or reqs '())]
|
||||
[lang (or lang '(begin))])
|
||||
(keyword-apply
|
||||
make-evaluator
|
||||
'(#:allow-read #:requires)
|
||||
(list (extract-requires lang reqs)
|
||||
(if beg-req? null reqs))
|
||||
(case lang
|
||||
[(r5rs beginner beginner-abbr intermediate intermediate-lambda advanced)
|
||||
(list 'special lang)]
|
||||
[else lang])
|
||||
(append
|
||||
(if beg-req? (cdr reqs) null)
|
||||
progs)))))]
|
||||
[(mod)
|
||||
(with-ns-params
|
||||
(lambda ()
|
||||
(make-module-evaluator mod)))]))
|
||||
(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 (make-mz-namespace)
|
||||
(let ([ns (mz:make-namespace)])
|
||||
;; Because scheme/sandbox needs scheme/base:
|
||||
(namespace-attach-module (namespace-anchor->namespace anchor)
|
||||
'scheme/base
|
||||
ns)
|
||||
ns))
|
||||
(define-namespace-anchor anchor)
|
||||
|
||||
(define (with-ns-params thunk)
|
||||
(let ([v (sandbox-namespace-specs)])
|
||||
(cond
|
||||
[(and (not gui?)
|
||||
(eq? (car v) make-base-namespace))
|
||||
(parameterize ([sandbox-namespace-specs
|
||||
(cons make-mz-namespace
|
||||
(cdr v))])
|
||||
(thunk))]
|
||||
[(and gui?
|
||||
(eq? (car v) (dynamic-require 'mred 'make-gui-namespace)))
|
||||
(parameterize ([sandbox-namespace-specs
|
||||
;; Simulate the old make-namespace-with-mred:
|
||||
(cons (lambda ()
|
||||
(let ([ns (make-mz-namespace)]
|
||||
[ns2 ((dynamic-require 'mred 'make-gui-namespace))])
|
||||
(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))))
|
||||
;; Compatbility:
|
||||
;; * recognize 'r5rs, etc, and wrap them as a list.
|
||||
;; * 'begin form of reqs
|
||||
;; * more agressively extract requires from lang and reqs
|
||||
(define *make-evaluator
|
||||
(case-lambda
|
||||
[(lang reqs . progs)
|
||||
(with-ns-params
|
||||
(lambda ()
|
||||
(let ([beg-req? (and (list? reqs)
|
||||
(pair? reqs)
|
||||
(eq? 'begin (car reqs)))]
|
||||
[reqs (or reqs '())]
|
||||
[lang (or lang '(begin))])
|
||||
(keyword-apply
|
||||
make-evaluator
|
||||
'(#:allow-read #:requires)
|
||||
(list (extract-requires lang reqs)
|
||||
(if beg-req? null reqs))
|
||||
(case lang
|
||||
[(r5rs beginner beginner-abbr intermediate intermediate-lambda
|
||||
advanced)
|
||||
(list 'special lang)]
|
||||
[else lang])
|
||||
(append (if beg-req? (cdr reqs) null) progs)))))]
|
||||
[(mod) (with-ns-params (lambda () (make-module-evaluator mod)))]))
|
||||
|
||||
(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)))
|
||||
(define (make-mz-namespace)
|
||||
(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)
|
||||
(let ([v (sandbox-namespace-specs)])
|
||||
(cond [(and (not gui?) (eq? (car v) make-base-namespace))
|
||||
(parameterize ([sandbox-namespace-specs
|
||||
(cons make-mz-namespace (cdr v))])
|
||||
(thunk))]
|
||||
[(and gui? (eq? (car v) (dynamic-require 'mred 'make-gui-namespace)))
|
||||
(parameterize
|
||||
([sandbox-namespace-specs
|
||||
;; Simulate the old make-namespace-with-mred:
|
||||
(cons (lambda ()
|
||||
(let ([ns (make-mz-namespace)]
|
||||
[ns2 ((dynamic-require
|
||||
'mred 'make-gui-namespace))])
|
||||
(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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user