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

Propagate path to syntax source of evaluated files when applicable

Browse Source 
Set `current-load-relative-directory' based on path when it names a directory.

svn: r17826
This commit is contained in:
Eli Barzilay 2010-01-25 21:02:15 +00:00
parent 8ccbe74e5e
commit 04725539c7
1 changed files with 13 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/scheme/sandbox.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/port (require scheme/port
scheme/path
scheme/list scheme/list
scheme/string scheme/string
syntax/moddep syntax/moddep
@ -444,7 +445,7 @@
(cond [(and p (null? (cdr inps))) (cond [(and p (null? (cdr inps)))
(port-count-lines! p) (port-count-lines! p)
(parameterize ([current-input-port p]) (parameterize ([current-input-port p])
(begin0 ((sandbox-reader) source) (begin0 ((sandbox-reader) (or (object-name p) source))
;; close a port if we opened it ;; close a port if we opened it
(unless (eq? p (car inps)) (close-input-port p))))] (unless (eq? p (car inps)) (close-input-port p))))]
[p (error 'input->code "ambiguous inputs: ~e" inps)] [p (error 'input->code "ambiguous inputs: ~e" inps)]
@ -550,11 +551,17 @@
(module->namespace `(quote ,(syntax-e mod)))))] (module->namespace `(quote ,(syntax-e mod)))))]
[_else #f])]) [_else #f])])
;; the actual evaluation happens under the specified limits ;; the actual evaluation happens under the specified limits
((limit-thunk (lambda () (parameterize ([current-load-relative-directory
(if (and (pair? program) (eq? 'begin (car program))) (let* ([d (syntax-source program)]
(eval* (cdr program)) [d (and (path-string? d) (path-only d))])
(eval program)) (if (and d (directory-exists? d))
(when ns (set! ns (ns)))))) d
(current-load-relative-directory)))])
((limit-thunk (lambda ()
(if (and (pair? program) (eq? 'begin (car program)))
(eval* (cdr program))
(eval program))
(when ns (set! ns (ns)))))))
(when uncovered! (when uncovered!
(let ([get (let ([ns (current-namespace)]) (let ([get (let ([ns (current-namespace)])
(lambda () (eval '(get-uncovered-expressions) ns)))]) (lambda () (eval '(get-uncovered-expressions) ns)))])