diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index 167c2c45dc..3052588932 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -317,9 +317,11 @@ (let* ([def-ctx (if star? (syntax-local-make-definition-context (car def-ctxes)) (last def-ctxes))] - [ids (if star? - (map (add-package-context (list def-ctx)) ids) - ids)]) + [ids (map + (lambda (id) (syntax-property id 'unshadowable #t)) + (if star? + (map (add-package-context (list def-ctx)) ids) + ids))]) (syntax-local-bind-syntaxes ids #'rhs def-ctx) (register-bindings! ids) (loop (cdr exprs) @@ -335,9 +337,11 @@ (let* ([def-ctx (if star? (syntax-local-make-definition-context (car def-ctxes)) (last def-ctxes))] - [ids (if star? - (map (add-package-context (list def-ctx)) ids) - ids)]) + [ids (map + (lambda (id) (syntax-property id 'unshadowable #t)) + (if star? + (map (add-package-context (list def-ctx)) ids) + ids))]) (syntax-local-bind-syntaxes ids #f def-ctx) (register-bindings! ids) (loop (cdr exprs) diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 37c3056b97..003a7a4eaa 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -576,8 +576,9 @@ exports of the module. Returns @scheme[id-stx] if no binding in the current expansion context shadows @scheme[id-stx] (ignoring unsealed @tech{internal-definition -contexts}), if @scheme[id-stx] has no module bindings in its lexical -information, and if the current expansion context is not a +contexts} and identifiers that had the @indexed-scheme['unshadowable] +@tech{syntax property}), if @scheme[id-stx] has no module bindings in +its lexical information, and if the current expansion context is not a @tech{module context}. If a binding of @scheme[inner-identifier] shadows @scheme[id-stx], the diff --git a/collects/tests/mzscheme/compile.ss b/collects/tests/mzscheme/compile.ss index 2137a8a52f..34a76a5c53 100644 --- a/collects/tests/mzscheme/compile.ss +++ b/collects/tests/mzscheme/compile.ss @@ -8,7 +8,7 @@ 'compile-load #f (lambda () - (namespace-set-variable-value! 'compile-load "quiet.ss"))) + (namespace-set-variable-value! 'compile-load "mzq.ss"))) (define file (if #f @@ -64,7 +64,7 @@ [(x next-eval) (if (or (compiled-expression? x) (and (syntax? x) (compiled-expression? (syntax-e x))) - (current-module-name-prefix)) + (current-module-declare-name)) (next-eval x) (begin ;; (fprintf file ": ~a~n" +) diff --git a/collects/tests/mzscheme/package-gen.ss b/collects/tests/mzscheme/package-gen.ss index c2891b18dc..62d5126e2f 100644 --- a/collects/tests/mzscheme/package-gen.ss +++ b/collects/tests/mzscheme/package-gen.ss @@ -59,8 +59,8 @@ (define combo-context-forms (list (lambda (p o) `(begin ,p ,o)) (lambda (p o) `(let () ,p ,o 10)) - (lambda (p o) `(package out1 all-defined ,p ,o)) - (lambda (p o) `(package out2 all-defined (package out1 all-defined ,p ,o))))) + (lambda (p o) `(define-package out1 #:all-defined ,p ,o)) + (lambda (p o) `(define-package out2 #:all-defined (define-package out1 #:all-defined ,p ,o))))) (define all-forms (apply diff --git a/collects/tests/mzscheme/package.ss b/collects/tests/mzscheme/package.ss index b907652e5e..c60a471180 100644 --- a/collects/tests/mzscheme/package.ss +++ b/collects/tests/mzscheme/package.ss @@ -39,6 +39,7 @@ (define (test-pack-seq* forms expr q-expr result) (let ([orig (current-namespace)]) + ;; top level (let ([ns (make-base-namespace)]) (parameterize ([current-namespace ns]) (namespace-attach-module orig 'scheme/package) @@ -48,6 +49,7 @@ (if (fail? expr) (err/rt-test (eval (fail-expr expr)) result) (test result q-expr (eval expr))))) + ;; let (let ([ns (make-base-namespace)]) (parameterize ([current-namespace ns]) (namespace-attach-module orig 'scheme/package) @@ -57,6 +59,21 @@ (if (fail? expr) (err/rt-test (eval e) result) (test result `(let ... ,q-expr) (eval e)))))) + ;; nested let + (let ([ns (make-base-namespace)]) + (parameterize ([current-namespace ns]) + (namespace-attach-module orig 'scheme/package) + (namespace-require '(for-syntax scheme/base)) + (namespace-require 'scheme/package) + (let ([e (let loop ([forms forms]) + (if (null? (cdr forms)) + `(let () (begin . ,forms) ,(fail-expr expr)) + `(let () ,(car forms) + ,(loop (cdr forms)))))]) + (if (fail? expr) + (err/rt-test (eval e) result) + (test result `(let ... ,q-expr) (eval e)))))) + ;; module (let ([ns (make-base-namespace)]) (parameterize ([current-namespace ns]) (namespace-attach-module orig 'scheme/package) diff --git a/collects/tests/mzscheme/parallel.ss b/collects/tests/mzscheme/parallel.ss index 037409ba6a..64a726e2d0 100644 --- a/collects/tests/mzscheme/parallel.ss +++ b/collects/tests/mzscheme/parallel.ss @@ -1,6 +1,4 @@ -do-not-run-me-yet - ;; Runs 3 threads perfoming the test suite simultaneously. Each ;; thread creates a directory sub to run in, so that filesystem ;; tests don't collide. diff --git a/collects/tests/mzscheme/prompt-sfs.ss b/collects/tests/mzscheme/prompt-sfs.ss index a967382bf5..ccc9ede999 100644 --- a/collects/tests/mzscheme/prompt-sfs.ss +++ b/collects/tests/mzscheme/prompt-sfs.ss @@ -1,16 +1,30 @@ #lang scheme +(require scheme/system) #| This test is designed to to check whether meta-continuations are correctly split when a continuation is delimited in the middle of -a meta-continuation other than the current one. In aprticular, +a meta-continuation other than the current one. In particular, the `x' binding is part of the deeper meta-continuation when `ak' is captured, but it is delimited inside the binding, so `x' should not be reated in `ak'. +The test is implemented using `dump-memory-stats' in another mzscheme +process. + |# +(when (equal? #() (current-command-line-arguments)) + (let ([f (find-executable-path (find-system-path 'exec-file) #f)]) + (let ([p (open-output-bytes)]) + (parameterize ([current-error-port p]) + (system* f "-l" "tests/mzscheme/prompt-sfs" "sub")) + (unless (regexp-match? #rx": +1 +" (get-output-bytes p)) + (error "wrong output") + (exit 1)))) + (exit 0)) + (define (make-big-thing) (cons (make-string 100000) (make-will-executor))) (define (show-big-thing say x) (say (string-length (car x)))) diff --git a/collects/tests/mzscheme/stream.ss b/collects/tests/mzscheme/stream.ss index 443166ea84..df6c622d21 100644 --- a/collects/tests/mzscheme/stream.ss +++ b/collects/tests/mzscheme/stream.ss @@ -1,6 +1,8 @@ (printf "Stream Tests (current dir must be startup dir)~n") +(require scheme/system) + (define (log . args) '(begin (apply printf args) @@ -9,13 +11,13 @@ (define cs-prog '(define (copy-stream in out) (lambda () - (let ([s (make-string 4096)]) + (let ([s (make-bytes 4096)]) (let loop () - (let ([l (read-string-avail! s in)]) + (let ([l (read-bytes-avail! s in)]) (log "in: ~a" l) (unless (eof-object? l) (let loop ([p 0][l l]) - (let ([r (write-string-avail s out p (+ p l))]) + (let ([r (write-bytes-avail s out p (+ p l))]) (log "out: ~a" r) (when (< r l) (loop (+ p r) (- l r))))) @@ -29,9 +31,9 @@ (define (feed-file out) (let ([p (open-input-file test-file)]) (let loop () - (let ([c (read-char p)]) + (let ([c (read-byte p)]) (unless (eof-object? c) - (write-char c out) + (write-byte c out) (loop)))))) (define (feed-file/fast out) @@ -42,15 +44,15 @@ (define (check-file in) (let ([p (open-input-file test-file)]) (let loop ([badc 0]) - (let ([c (read-char p)] - [c2 (read-char in)]) + (let ([c (read-byte p)] + [c2 (read-byte in)]) (unless (eq? c c2) (if (= badc 30) (error "check-failed" (file-position p) c c2) (begin (fprintf (current-error-port) - "fail: ~a ~s ~s~n" - (file-position p) c c2) + "fail: ~a ~s=~s ~s=~s~n" + (file-position p) c (integer->char c) c2 (integer->char c2)) (loop (add1 badc))))) (unless (eof-object? c) (loop badc)))) @@ -59,8 +61,8 @@ (define (check-file/fast in) (let ([p (open-input-file test-file)]) (let loop () - (let* ([s (read-string 5000 p)] - [s2 (read-string (if (string? s) (string-length s) 100) in)]) + (let* ([s (read-bytes 5000 p)] + [s2 (read-bytes (if (bytes? s) (bytes-length s) 100) in)]) (unless (equal? s s2) (error "fast check failed")) (unless (eof-object? s) @@ -69,23 +71,23 @@ (define (check-file/fastest in) (let ([p (open-input-file test-file)] - [s1 (make-string 5000)] - [s2 (make-string 5000)]) + [s1 (make-bytes 5000)] + [s2 (make-bytes 5000)]) (let loop ([leftover 0][startpos 0][pos 0]) (let* ([n1 (if (zero? leftover) - (read-string-avail! s1 p) + (read-bytes-avail! s1 p) leftover)] - [n2 (read-string-avail! s2 in 0 (if (eof-object? n1) - 1 + [n2 (read-bytes-avail! s2 in 0 (if (eof-object? n1) + 1 n1))]) (unless (if (or (eof-object? n1) (eof-object? n2)) (and (eof-object? n1) (eof-object? n2)) (if (= n2 n1 5000) - (string=? s1 s2) - (string=? (substring s1 startpos (+ startpos n2)) - (substring s2 0 n2)))) + (bytes=? s1 s2) + (bytes=? (subbytes s1 startpos (+ startpos n2)) + (subbytes s2 0 n2)))) (error 'check "failed at ~a (~a@~a ~a)" pos n1 startpos n2)) (unless (eof-object? n1) (loop (- n1 n2) @@ -95,11 +97,11 @@ (+ pos n2))))) (close-input-port p))) -(define portno 40000) +(define portno 40010) (define (setup-mzscheme-echo tcp?) (define p (process* test-file "-q" "-b")) - (define s (make-string 256)) + (define s (make-bytes 256)) (define r #f) (define w #f) (define r2 #f) @@ -118,18 +120,18 @@ (set! w2 ww2)))]) (fprintf (cadr p) "(define-values (r w) (tcp-connect \"localhost\" ~a))~n" portno) (fprintf (cadr p) "(define-values (r2 w2) (tcp-connect \"localhost\" ~a))~n" (add1 portno)) + (flush-output (cadr p)) (thread-wait t) (fprintf (cadr p) "(begin ((copy-stream r w2)) (exit))~n")) - (fprintf (cadr p) "(begin ((copy-stream (current-input-port) (current-output-port))) (exit))~n")) + (fprintf (cadr p) "(begin (flush-output) ((copy-stream (current-input-port) (current-output-port))) (exit))~n")) + (flush-output (cadr p)) - ;; Flush initial output: - (read-string (string-length (banner)) (car p)) - (sleep 0.3) - (when (char-ready? (car p)) - (read-string-avail! s (car p))) - (sleep 0.3) - (when (char-ready? (car p)) - (read-string-avail! s (car p))) + (unless tcp? + ;; Flush initial output from other process: + (let loop () + (sleep 0.3) + (unless (zero? (read-bytes-avail!* s (car p))) + (loop)))) (if tcp? (values r w r2 w2) @@ -218,7 +220,7 @@ (start "To file and back:~n") (start " to...~n") (define-values (r w) (make-pipe)) -(define p (open-output-file tmp-file 'truncate)) +(define p (open-output-file tmp-file #:exists 'truncate)) (define t (thread (copy-stream r p))) (feed-file w) (close-output-port w) @@ -239,7 +241,7 @@ (start "To file and back, faster:~n") (start " to...~n") (define-values (r w) (make-pipe)) -(define p (open-output-file tmp-file 'truncate)) +(define p (open-output-file tmp-file #:exists 'truncate)) (define t (thread (copy-stream r p))) (feed-file/fast w) (close-output-port w) @@ -295,8 +297,8 @@ (check-file/fast rp2) (end) -(define l1 (tcp-listen portno)) -(define l2 (tcp-listen (add1 portno))) +(define l1 (tcp-listen portno 5 #t)) +(define l2 (tcp-listen (add1 portno) 5 #t)) (start "TCP Echo...~n") (define-values (r w r2 w2) (setup-mzscheme-echo #t)) diff --git a/src/mzscheme/cmdline.inc b/src/mzscheme/cmdline.inc index 9194656ae0..1c4901c88e 100644 --- a/src/mzscheme/cmdline.inc +++ b/src/mzscheme/cmdline.inc @@ -981,7 +981,7 @@ static int run_from_cmd_line(int argc, char *_argv[], #endif ) #endif - PRINTF(BANNER); + PRINTF("%s", BANNER); #ifdef MZSCHEME_CMD_LINE # ifdef DOS_FILE_SYSTEM # if !defined(FILES_HAVE_FDS) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 8336e4776e..5c9659a586 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -182,6 +182,8 @@ static void init_compile_data(Scheme_Comp_Env *env); #define ASSERT_IS_VARIABLE_BUCKET(b) /* if (((Scheme_Object *)b)->type != scheme_variable_type) abort() */ +static Scheme_Object *unshadowable_symbol; + /*========================================================================*/ /* initialization */ /*========================================================================*/ @@ -632,6 +634,9 @@ static void make_kernel_env(void) scheme_current_thread->name = sym; } + REGISTER_SO(unshadowable_symbol); + unshadowable_symbol = scheme_intern_symbol("unshadowable"); + DONE_TIME(env); scheme_install_type_writer(scheme_toplevel_type, write_toplevel); @@ -4687,7 +4692,7 @@ static Scheme_Object * local_get_shadower(int argc, Scheme_Object *argv[]) { Scheme_Comp_Env *env, *frame; - Scheme_Object *sym, *esym, *sym_marks = NULL, *orig_sym, *uid = NULL, *env_marks; + Scheme_Object *sym, *esym, *sym_marks = NULL, *orig_sym, *uid = NULL, *env_marks, *prop; env = scheme_current_thread->current_local_env; if (!env) @@ -4712,16 +4717,19 @@ local_get_shadower(int argc, Scheme_Object *argv[]) for (i = frame->num_bindings; i--; ) { if (frame->values[i]) { if (SAME_OBJ(SCHEME_STX_VAL(sym), SCHEME_STX_VAL(frame->values[i]))) { - esym = frame->values[i]; - env_marks = scheme_stx_extract_marks(esym); - if (scheme_equal(env_marks, sym_marks)) { - sym = esym; - if (frame->uids) - uid = frame->uids[i]; - else - uid = frame->uid; - break; - } + prop = scheme_stx_property(frame->values[i], unshadowable_symbol, NULL); + if (SCHEME_FALSEP(prop)) { + esym = frame->values[i]; + env_marks = scheme_stx_extract_marks(esym); + if (scheme_equal(env_marks, sym_marks)) { + sym = esym; + if (frame->uids) + uid = frame->uids[i]; + else + uid = frame->uid; + break; + } + } } } } @@ -4734,14 +4742,17 @@ local_get_shadower(int argc, Scheme_Object *argv[]) if (SAME_OBJ(SCHEME_STX_VAL(sym), SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]))) { esym = COMPILE_DATA(frame)->const_names[i]; - env_marks = scheme_stx_extract_marks(esym); - if (scheme_equal(env_marks, sym_marks)) { /* This used to have 1 || --- why? */ - sym = esym; - if (COMPILE_DATA(frame)->const_uids) - uid = COMPILE_DATA(frame)->const_uids[i]; - else - uid = frame->uid; - break; + prop = scheme_stx_property(esym, unshadowable_symbol, NULL); + if (SCHEME_FALSEP(prop)) { + env_marks = scheme_stx_extract_marks(esym); + if (scheme_equal(env_marks, sym_marks)) { /* This used to have 1 || --- why? */ + sym = esym; + if (COMPILE_DATA(frame)->const_uids) + uid = COMPILE_DATA(frame)->const_uids[i]; + else + uid = frame->uid; + break; + } } } }