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

svn: r17075

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? 
+                                 [ids (map
-                                          (map (add-package-context (list def-ctx)) ids)
+                                       (lambda (id) (syntax-property id 'unshadowable #t))
-                                          ids)])
+                                       (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? 
+                               [ids (map
-                                        (map (add-package-context (list def-ctx)) ids)
+                                     (lambda (id) (syntax-property id 'unshadowable #t))
-                                        ids)])
+                                     (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)

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
+contexts} and identifiers that had the @indexed-scheme['unshadowable]
-information, and if the current expansion context is not a
+@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

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

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) `(define-package out1 #:all-defined ,p ,o))
-	(lambda (p o) `(package out2 all-defined (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

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)

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<n> to run in, so that filesystem
 ;;  tests don't collide.

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

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)]
+      (let ([c (read-byte p)]
-	    [c2 (read-char in)])
+	    [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"
+			 "fail: ~a ~s=~s ~s=~s~n"
-			 (file-position p) c c2)
+			 (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)]
+      (let* ([s (read-bytes 5000 p)]
-	     [s2 (read-string (if (string? s) (string-length s) 100) in)])
+	     [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)]
+	[s1 (make-bytes 5000)]
-	[s2 (make-string 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)
+	     [n2 (read-bytes-avail! s2 in 0 (if (eof-object? n1)
-						 1
+                                                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)
+			(bytes=? s1 s2)
-			(string=? (substring s1 startpos (+ startpos n2))
+			(bytes=? (subbytes s1 startpos (+ startpos n2))
-				  (substring s2 0 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:
+  (unless tcp?
-  (read-string (string-length (banner)) (car p))
+    ;; Flush initial output from other process:
-  (sleep 0.3)
+    (let loop ()
-  (when (char-ready? (car p))
+      (sleep 0.3)
-    (read-string-avail! s (car p)))
+      (unless (zero? (read-bytes-avail!* s (car p)))
-  (sleep 0.3)
+        (loop))))
-  (when (char-ready? (car p))
-    (read-string-avail! s (car p)))
 
   (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 l1 (tcp-listen portno 5 #t))
-(define l2 (tcp-listen (add1 portno)))
+(define l2 (tcp-listen (add1 portno) 5 #t))
 
 (start "TCP Echo...~n")
 (define-values (r w r2 w2) (setup-mzscheme-echo #t))

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)

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];
+          prop = scheme_stx_property(frame->values[i], unshadowable_symbol, NULL);
-	  env_marks = scheme_stx_extract_marks(esym);
+          if (SCHEME_FALSEP(prop)) {
-	  if (scheme_equal(env_marks, sym_marks)) {
+            esym = frame->values[i];
-	    sym = esym;
+            env_marks = scheme_stx_extract_marks(esym);
-	    if (frame->uids)
+            if (scheme_equal(env_marks, sym_marks)) {
-	      uid = frame->uids[i];
+              sym = esym;
-	    else
+              if (frame->uids)
-	      uid = frame->uid;
+                uid = frame->uids[i];
-	    break;
+              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);
+            prop = scheme_stx_property(esym, unshadowable_symbol, NULL);
-            if (scheme_equal(env_marks, sym_marks)) { /* This used to have 1 || --- why? */
+            if (SCHEME_FALSEP(prop)) {
-              sym = esym;
+              env_marks = scheme_stx_extract_marks(esym);
-              if (COMPILE_DATA(frame)->const_uids)
+              if (scheme_equal(env_marks, sym_marks)) { /* This used to have 1 || --- why? */
-                uid = COMPILE_DATA(frame)->const_uids[i];
+                sym = esym;
-              else
+                if (COMPILE_DATA(frame)->const_uids)
-                uid = frame->uid;
+                  uid = COMPILE_DATA(frame)->const_uids[i];
-              break;
+                else
+                  uid = frame->uid;
+                break;
+              }
             }
 	  }
 	}