diff --git a/collects/meta/props b/collects/meta/props index 55dfc98dc9..992cc7cd4e 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1979,6 +1979,7 @@ path/s is either such a string or a list of them. "collects/tests/xml" responsible (jay) "collects/tests/xml/test-clark.rkt" drdr:command-line #f drdr:timeout 300 "collects/tests/xml/xml-snip-bug.rkt" drdr:command-line (gracket "-t" *) +"collects/tests/xrepl" responsible (eli) "collects/tests/zo-size.rkt" responsible (jay) "collects/tex2page" responsible (jay) "collects/texpict" responsible (mflatt robby) diff --git a/collects/tests/xrepl/main.rkt b/collects/tests/xrepl/main.rkt new file mode 100644 index 0000000000..e73c7b3408 --- /dev/null +++ b/collects/tests/xrepl/main.rkt @@ -0,0 +1,94 @@ +#lang at-exp racket/base + +(define verbose? (make-parameter #t)) + +(define global-ns (current-namespace)) + +(define stderr (current-error-port)) + +(define (test-xrepl . args) + (define show-all? (verbose?)) + (define-values [Ii Io] (make-pipe)) + (define-values [Oi Oo] (make-pipe)) + (define repl-thread + (parameterize ([current-input-port Ii] + [current-output-port Oo] + [current-error-port Oo] + [current-namespace (make-empty-namespace)] + [error-print-context-length 0] ; easier output + [exit-handler (λ (_) (kill-thread repl-thread))]) + (thread (λ () + (namespace-attach-module global-ns 'racket/base) + (namespace-require 'racket) + (dynamic-require 'xrepl #f) + (read-eval-print-loop))))) + (define (repl-> expected) + (define output (read-string (string-length expected) Oi)) + (if (equal? output expected) + (when show-all? (display output)) + (error 'xrepl "test failure, expected ~s, got ~s" expected output))) + (let loop ([strs args] [input? #f]) + (cond + [(and (pair? strs) (equal? "" (car strs))) + (loop (cdr strs) input?)] + [(and (thread-dead? repl-thread) (null? strs)) + (printf "All tests passed.\n")] + [(thread-dead? repl-thread) + (error 'xrepl "test failure, repl thread died unexpectedly")] + [(null? strs) + (if (sync/timeout 1 repl-thread) + (loop strs input?) + (error 'xrepl "test failure, repl thread is alive at end of tests"))] + [(eq? '« (car strs)) + (when input? (error 'xrepl "bad test: unterminated `«'")) + (loop (cdr strs) #t)] + [(eq? '» (car strs)) + (unless input? (error 'xrepl "bad test: redundant `»'")) + (loop (cdr strs) 'newline)] + [(regexp-match #rx"^(.*?)(?: *⇒[^\n]*)(.*)" (car strs)) + => (λ (m) (loop (list* (cadr m) (caddr m) (cdr strs)) input?))] + [(regexp-match #rx"^(.*?)([«»])(.*)" (car strs)) + => (λ (m) (loop (list* (cadr m) (string->symbol (caddr m)) (cadddr m) + (cdr strs)) + input?))] + [(eq? 'newline input?) + (unless (regexp-match? #rx"^\n" (car strs)) + (error 'xrepl "bad test: `»' followed by a non-newline")) + (newline Io) (flush-output Io) + (when show-all? (newline) (flush-output)) + (loop (cons (substring (car strs) 1) (cdr strs)) #f)] + [input? + (display (car strs) Io) + (when show-all? (display (car strs)) (flush-output)) + (loop (cdr strs) #t)] + [else + (repl-> (car strs)) + (loop (cdr strs) #f)]))) + +@test-xrepl|={ + -> «(- 2 1)» + 1 + -> «(values 2 3)» + 2 + 3 + -> «(values 4)» + 4 + -> «(list ^ ^^ ^^^ ^^^^)» + '(4 3 2 1) + -> «(module foo racket (define x 123))» + -> «,en foo» + 'foo> «x» + 123 + 'foo> «,top» + -> «(define enter! 123)» + -> «(enter! 'foo)» + procedure application: expected procedure, given: 123; arguments were: 'foo + -> «,en foo» ⇒ but this still works + 'foo> «,top» + -> «,switch foo» + ; *** Initializing a new `foo' namespace with "racket/main.rkt" *** + ; *** Switching to the `foo' namespace *** + foo::-> «,switch *» + ; *** Switching to the `*' namespace *** + -> «,ex» + |=@||}=| diff --git a/collects/xrepl/xrepl.rkt b/collects/xrepl/xrepl.rkt index a701b3583c..555818d125 100644 --- a/collects/xrepl/xrepl.rkt +++ b/collects/xrepl/xrepl.rkt @@ -23,7 +23,8 @@ (define (autoloaded? sym) (hash-ref autoloaded-specs sym #f)) (define-syntax-rule (defautoload libspec id ...) (begin (define (id . args) - (set! id (dynamic-require 'libspec 'id)) + (set! id (parameterize ([current-namespace hidden-namespace]) + (dynamic-require 'libspec 'id))) (hash-set! autoloaded-specs 'libspec #t) (hash-set! autoloaded-specs 'id #t) (apply id args)) @@ -38,13 +39,25 @@ ;; similar, but just for identifiers (define-namespace-anchor anchor) (define (here-namespace) (namespace-anchor->namespace anchor)) +(define hidden-namespace (make-base-namespace)) +(define initial-namespace (current-namespace)) +;; when `racket/enter' initializes, it grabs the `current-namespace' to get +;; back to -- which means it should be instantiated in a top level namespace +;; rather than in (here-namespace); but if we use `initial-namespace' we +;; essentially rely on the user to not kill `enter!' (eg, (define enter! 4)). +;; the solution is to make a `hidden-namespace' where we store these bindings, +;; then instantiate needed modules in the initial namespace and immediately +;; attach the modules to the hidden one then use it, so changes to the binding +;; in `initial-namespace' doesn't affect us. (define (make-lazy-identifier sym from) (define id #f) - (λ () (or id (parameterize ([current-namespace (here-namespace)]) - (eval (namespace-syntax-introduce - (datum->syntax #f #`(require #,from)))) - (set! id (namespace-symbol->identifier sym)) - id)))) + (λ () (or id (begin (parameterize ([current-namespace initial-namespace]) + (namespace-require from)) + (parameterize ([current-namespace hidden-namespace]) + (namespace-attach-module initial-namespace from) + (namespace-require from) + (set! id (namespace-symbol->identifier sym)) + id))))) ;; makes it easy to use meta-tools without user-namespace contamination (define (eval-sexpr-for-user form) @@ -58,10 +71,9 @@ (if (path-string? x) (path->relative-string/setup x) x)) (define (here-source) ; returns a path, a symbol, or #f (= not in a module) - (let* ([x (datum->syntax #'here '(#%variable-reference))] - [x (eval (namespace-syntax-introduce x))] - [x (variable-reference->module-source x)]) - x)) + (variable-reference->module-source + (eval (namespace-syntax-introduce + (datum->syntax #f `(,#'#%variable-reference)))))) (define (phase->name phase [fmt #f]) (define s @@ -967,7 +979,7 @@ (λ () (let ([base-stxs #f]) (unless base-stxs (set! base-stxs ; all ids that are bound to a syntax in racket/base - (parameterize ([current-namespace (here-namespace)]) + (parameterize ([current-namespace hidden-namespace]) (let-values ([(vals stxs) (module->exports 'racket/base)]) (map (λ (s) (namespace-symbol->identifier (car s))) (cdr (assq 0 stxs)))))))