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

another syntax hack to fix 'scheme/package'; other test corrections

Browse Source 
svn: r17075
This commit is contained in:
Matthew Flatt 2009-11-27 02:12:27 +00:00
parent 64e018fffa
commit f03ab78c40
10 changed files with 116 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/scheme/package.ss
View File

@ -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)

5
collects/scribblings/reference/stx-trans.scrbl
View File

@ -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

4
collects/tests/mzscheme/compile.ss
View File

@ -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" +)

4
collects/tests/mzscheme/package-gen.ss
View File

@ -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

17
collects/tests/mzscheme/package.ss
View File

@ -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)

2
collects/tests/mzscheme/parallel.ss
View File

@ -1,6 +1,4 @@
do-not-run-me-yet
;; Runs 3 threads perfoming the test suite simultaneously. Each
;; thread creates a directory sub<n> to run in, so that filesystem
;; tests don't collide.

16
collects/tests/mzscheme/prompt-sfs.ss
View File

@ -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"<will-executor>: +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))))

70
collects/tests/mzscheme/stream.ss
View File

@ -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))

2
src/mzscheme/cmdline.inc
View File

@ -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)

49
src/mzscheme/src/env.c
View File

@ -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;
}
}
}
}