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

switch to #lang, reformat

Browse Source 
svn: r12655

original commit: 7ea8ab6592e4ea96121d24c3b3fa4ed355e653cd
This commit is contained in:
Eli Barzilay 2008-12-01 03:21:46 +00:00
parent 510305451c
commit 75308c9158
1 changed files with 113 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
collects/mzlib/sandbox.ss
View File

@ -1,7 +1,9 @@
(module sandbox scheme/base #lang scheme/base
(require scheme/sandbox
(require scheme/sandbox
(prefix-in mz: (only-in mzscheme make-namespace))) (prefix-in mz: (only-in mzscheme make-namespace)))
(provide sandbox-init-hook
(provide sandbox-init-hook
sandbox-reader sandbox-reader
sandbox-input sandbox-input
sandbox-output sandbox-output
@ -29,13 +31,13 @@
(rename-out [*make-evaluator make-evaluator] (rename-out [*make-evaluator make-evaluator]
[gui? mred?])) [gui? mred?]))
(define-namespace-anchor anchor) (define-namespace-anchor anchor)
;; Compatbility: ;; Compatbility:
;; * recognize 'r5rs, etc, and wrap them as a list. ;; * recognize 'r5rs, etc, and wrap them as a list.
;; * 'begin form of reqs ;; * 'begin form of reqs
;; * more agressively extract requires from lang and reqs ;; * more agressively extract requires from lang and reqs
(define *make-evaluator (define *make-evaluator
(case-lambda (case-lambda
[(lang reqs . progs) [(lang reqs . progs)
(with-ns-params (with-ns-params
@ -51,41 +53,34 @@
(list (extract-requires lang reqs) (list (extract-requires lang reqs)
(if beg-req? null reqs)) (if beg-req? null reqs))
(case lang (case lang
[(r5rs beginner beginner-abbr intermediate intermediate-lambda advanced) [(r5rs beginner beginner-abbr intermediate intermediate-lambda
advanced)
(list 'special lang)] (list 'special lang)]
[else lang]) [else lang])
(append (append (if beg-req? (cdr reqs) null) progs)))))]
(if beg-req? (cdr reqs) null) [(mod) (with-ns-params (lambda () (make-module-evaluator mod)))]))
progs)))))]
[(mod)
(with-ns-params
(lambda ()
(make-module-evaluator mod)))]))
(define (make-mz-namespace) (define (make-mz-namespace)
(let ([ns (mz:make-namespace)]) (let ([ns (mz:make-namespace)])
;; Because scheme/sandbox needs scheme/base: ;; Because scheme/sandbox needs scheme/base:
(namespace-attach-module (namespace-anchor->namespace anchor) (namespace-attach-module (namespace-anchor->namespace anchor)
'scheme/base 'scheme/base ns)
ns)
ns)) ns))
(define (with-ns-params thunk) (define (with-ns-params thunk)
(let ([v (sandbox-namespace-specs)]) (let ([v (sandbox-namespace-specs)])
(cond (cond [(and (not gui?) (eq? (car v) make-base-namespace))
[(and (not gui?)
(eq? (car v) make-base-namespace))
(parameterize ([sandbox-namespace-specs (parameterize ([sandbox-namespace-specs
(cons make-mz-namespace (cons make-mz-namespace (cdr v))])
(cdr v))])
(thunk))] (thunk))]
[(and gui? [(and gui? (eq? (car v) (dynamic-require 'mred 'make-gui-namespace)))
(eq? (car v) (dynamic-require 'mred 'make-gui-namespace))) (parameterize
(parameterize ([sandbox-namespace-specs ([sandbox-namespace-specs
;; Simulate the old make-namespace-with-mred: ;; Simulate the old make-namespace-with-mred:
(cons (lambda () (cons (lambda ()
(let ([ns (make-mz-namespace)] (let ([ns (make-mz-namespace)]
[ns2 ((dynamic-require 'mred 'make-gui-namespace))]) [ns2 ((dynamic-require
'mred 'make-gui-namespace))])
(namespace-attach-module ns2 'mred ns) (namespace-attach-module ns2 'mred ns)
(namespace-attach-module ns2 'scheme/class ns) (namespace-attach-module ns2 'scheme/class ns)
(parameterize ([current-namespace ns]) (parameterize ([current-namespace ns])
@ -96,11 +91,10 @@
(thunk))] (thunk))]
[else (thunk)]))) [else (thunk)])))
(define (literal-identifier=? x y) (define (literal-identifier=? x y)
(or (free-identifier=? x y) (or (free-identifier=? x y) (eq? (syntax-e x) (syntax-e y))))
(eq? (syntax-e x) (syntax-e y))))
(define (extract-requires language requires) (define (extract-requires language requires)
(define (find-requires forms) (define (find-requires forms)
(let loop ([forms (reverse forms)] [reqs '()]) (let loop ([forms (reverse forms)] [reqs '()])
(if (null? forms) (if (null? forms)
@ -121,4 +115,4 @@
(append (find-requires (cdr language)) requires)] (append (find-requires (cdr language)) requires)]
[else (error 'extract-requires [else (error 'extract-requires
"bad language spec: ~e" language)])]) "bad language spec: ~e" language)])])
requires))) requires))