369.7

svn: r5506

collects/mzlib/port.ss

@@ -517,7 +517,8 @@
 			(begin
 			  ;; This means that we let too many bytes
 			  ;;  get written while a special was pending.
-			  ;;  Too bad...
+			  ;;  (The limit is disabled when a special
+                          ;;  is in the pipe.)
 			  (set-car! more (subbytes (car more) wrote))
 			  ;; By peeking, make room for more:
 			  (peek-byte r (sub1 (min (pipe-content-length w)
@@ -589,7 +590,6 @@
 						 (list 'reply (cadr req) (caddr req) v))])
 				    (case (car req)
 				      [(read)
-				       (printf "read~n")
 				       (reply (read-one (cadddr req)))]
 				      [(close)
 				       (reply (close-it))]
@@ -640,7 +640,8 @@
 							(min (- end start)
 							     (max 0
 								  (- limit (pipe-content-length w)))))])
-					  (if (zero? len)
+					  (if (and (zero? len)
+                                                   (null? more))
 					      (handle-evt w (lambda (x) (loop reqs)))
 					      (handle-evt (channel-put-evt (cadr req) len)
 							  (lambda (x)
@@ -673,7 +674,7 @@
 	       (call-with-semaphore
 		lock-semaphore
 		(lambda ()
-		  (unless via-manager?
+		  (unless mgr-th
 		    (set! mgr-th (thread serve)))
 		  (set! via-manager? #t)
 		  (thread-resume mgr-th (current-thread))

collects/tests/mzscheme/number.ss

@@ -193,7 +193,9 @@
   
 (test-compare 0.5 1.2 2.3)
 (test-compare 2/5 1/2 2/3)
-(test-compare 1/4 1/3 1/2)
+(test-compare 1/4 1/3 1/2) ; same numerator
+(test-compare 3/10 7/10 9/10) ; same denominator
+(test-compare 2/500000000000000000000000000 1/200000000000000000000000000 2/300000000000000000000000000) ; bignums
 (test #t = 1/2 2/4)
 (test #f = 2/3 2/5)
 (test #f = 2/3 2/500000000000000000000000000)

collects/tests/mzscheme/parallel.ss

@@ -10,55 +10,77 @@
 		    "quiet.ss"))])
   (namespace-variable-value 'parallel-load))
 
-(define (start x) (x))
+(define in-shared-k #f)
-
+;; Some threads start with the
-;; Uncomment the following expression to have threads start with the
 ;;  same continuation, which forces sharing of the Scheme stack:
-#;
 (thread-wait
- (thread (lambda () ((let/cc k (set! start k) void)))))
+ (thread (lambda () ((let/cc k (set! in-shared-k k) void)))))
+
+(define (start n x) 
+  (if (odd? n)
+      (x)
+      (in-shared-k x)))
 
 ; Runs n versions of test in parallel threads and namespaces, 
 ; waiting until all are done
 (define (parallel n test)
   (let ([done (make-semaphore)]
-	[go (make-semaphore)])
+	[go (make-semaphore)]
+        [custodians (let loop ([n n])
+                      (if (zero? n)
+                          null
+                          (cons (make-custodian) (loop (sub1 n)))))])
     (let loop ([n n])
       (unless (zero? n)
-	      (let ([ns (make-namespace)])
+        (let ([ns (make-namespace)]
-		(thread
+              [eh (exit-handler)]
-		 (lambda ()
+              [cust (list-ref custodians (sub1 n))])
-		   (start
+          (parameterize ([current-custodian cust])
-		    (lambda ()
+            (thread
-		      (parameterize ([current-namespace ns])
+             (lambda ()
-			(namespace-transformer-require 'mzscheme)
+               (start
-			(let ([dirname (format "sub~s" n)])
+                n
-			  (when (directory-exists? dirname)
+                (lambda ()
-			    (delete-directory* dirname))
+                  (parameterize ([current-namespace ns]
-			  (make-directory dirname)
+                                 [exit-handler (lambda (v)
-			  (current-directory dirname)
+                                                 (for-each (lambda (c)
-			  (dynamic-wind
+                                                             (unless (eq? c cust)
-			      void
+                                                               (custodian-shutdown-all c)))
-			      (lambda ()
+                                                           custodians)
-				(load test))
+                                                 (eh v))])
-			      (lambda ()
+                    (namespace-transformer-require 'mzscheme)
-				(semaphore-post done)
+                    (eval `(define Section-prefix ,(format "~a:" n)))
-				(semaphore-wait go)
+                    (let ([dirname (format "sub~s" n)])
-				(printf "~nThread ~s:" n)
+                      (when (directory-exists? dirname)
-				(eval '(report-errs))
+                        (delete-directory* dirname))
-				(current-directory (build-path 'up))
+                      (make-directory dirname)
-				(delete-directory* dirname)
+                      (current-directory dirname)
-				(semaphore-post done)))))))))
+                      (dynamic-wind
-		(loop (sub1 n)))))
+                          void
-    (let loop ([n n])
+                          (lambda ()
-      (unless (zero? n)
+                            (load test))
-	      (semaphore-wait done)
+                          (lambda ()
-	      (loop (sub1 n))))
+                            (semaphore-post done)
-    (let loop ([n n])
+                            (semaphore-wait go)
-      (unless (zero? n)
+                            (printf "~nThread ~s:" n)
-	      (semaphore-post go)
+                            (eval '(report-errs))
-	      (semaphore-wait done)
+                            (current-directory (build-path 'up))
-	      (loop (sub1 n))))))
+                            (delete-directory* dirname)
+                            (semaphore-post done))))))))))
+          (loop (sub1 n)))))
+    (with-handlers ([exn? (lambda (exn)
+                            (for-each custodian-shutdown-all
+                                      custodians)
+                            (raise exn))])
+      (let loop ([n n])
+        (unless (zero? n)
+          (semaphore-wait done)
+          (loop (sub1 n))))
+      (let loop ([n n])
+        (unless (zero? n)
+          (semaphore-post go)
+          (semaphore-wait done)
+          (loop (sub1 n)))))))
 
 (define (delete-directory* dir)
   (for-each (lambda (f)

collects/tests/mzscheme/path.ss

@@ -834,8 +834,18 @@
 (when (eq? 'unix (system-path-convention-type))
   (test-~-paths 'unix #f))
 
+;; Assuming a reasonable locale...
+(test "Apple" path-element->string (string->path-element "Apple"))
+(test "Apple" path-element->string (bytes->path-element #"Apple"))
+
 (err/rt-test (path-element->bytes (string->path ".")))
 (err/rt-test (path-element->bytes (string->path "..")))
+(err/rt-test (bytes->path-element #"." 'unix))
+(err/rt-test (bytes->path-element #".." 'unix))
+(err/rt-test (bytes->path-element "a/b" 'unix))
+(err/rt-test (bytes->path-element "a\\b" 'windows))
+
+(test #"\\\\?\\REL\\\\a/b" path->bytes (bytes->path-element #"a/b" 'windows))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

collects/tests/mzscheme/port.ss

@@ -474,8 +474,11 @@
 
 (let-values ([(in out) (make-pipe 3)])
   (test 3 write-bytes-avail #"12345" out)
+  (test #f sync/timeout 0 out)
   (test #\1 peek-char in)
+  (test out sync/timeout 0 out)
   (test 1 write-bytes-avail #"12345" out)
+  (test #f sync/timeout 0 out)
   (test #\1 peek-char in)
   (test 0 write-bytes-avail* #"12345" out)
   (test #\2 peek-char in 1)

collects/tests/mzscheme/portlib.ss

@@ -26,14 +26,14 @@
 	   [th (thread
 		(lambda ()
 		  (set! r (port-commit-peeked 3 unless-evt never-evt in))))])
-      (sleep SLEEP-TIME)
+      (sync (system-idle-evt))
       (test #t thread-running? th)
       (test #\b peek-char in)
-      (sleep SLEEP-TIME)
+      (sync (system-idle-evt))
       (test #t thread-running? th)
       (test #f sync/timeout 0 unless-evt)
       (test #\b read-char in)
-      (sleep SLEEP-TIME)
+      (sync (system-idle-evt))
       (test th sync th)
       (test #f values r))
     (test "anana" read-string 5 in)
@@ -50,29 +50,29 @@
 		       [th1 (thread
 			     (lambda ()
 			       (set! r1 (port-commit-peeked 1 unless-evt s1 in))))]
-		       [_ (sleep SLEEP-TIME)]
+		       [_ (sync (system-idle-evt))]
 		       [th2 (thread
 			     (lambda ()
 			       (set! r2 (port-commit-peeked 2 unless-evt (semaphore-peek-evt s2) in))))])
-		  (sleep SLEEP-TIME)
+                  (sync (system-idle-evt))
 		  (when suspend/kill
 		    (case suspend/kill
 		      [(suspend) (thread-suspend th1)]
 		      [(kill) (kill-thread th1)])
-		    (sleep SLEEP-TIME))
+                    (sync (system-idle-evt)))
 		  (test (eq? suspend/kill 'kill) thread-dead? th1)
 		  (test #f thread-dead? th2)
 		  (when peek?
 		    (test #"do" peek-bytes 2 0 in)
-		    (sleep SLEEP-TIME))
+                    (sync (system-idle-evt)))
 		  (unless (= which 3)
 		    (semaphore-post (if (= which 1) s1 s2)))
 		  (when (= which 3)
 		    (test #"do" read-bytes 2 in))
-		  (sleep SLEEP-TIME)
+                  (sync (system-idle-evt))
 		  (test unless-evt sync/timeout 0 unless-evt)
 		  (test (not (eq? suspend/kill 'suspend)) thread-dead? th1)
-		  (sleep SLEEP-TIME)
+                  (sync (system-idle-evt))
 		  (test #t thread-dead? th2)
 		  (test (if (= which 1) #t (if suspend/kill '? #f)) values r1)
 		  (test (= which 2) values r2)
@@ -108,18 +108,20 @@
       (define (bg thunk runs? spec? exn?)
 	;; Fill the pipe, again:
 	(test 10 write-bytes (make-bytes 10 66) out)
+        (sync (system-idle-evt))
 	(let* ([ex #f]
 	       [th (thread 
 		    (lambda ()
 		      (with-handlers ([exn:fail? (lambda (x) 
 						   (set! ex #t)
 						   (raise x))])
-			(sync (write-bytes-avail-evt #"x" out)))))])
+                        (let ([evt (write-bytes-avail-evt #"x" out)])
-	  (sleep SLEEP-TIME)
+                          (sync evt)))))])
+          (sync (system-idle-evt))
 	  (test #t thread-running? th)
 	  ;; This thunk (and sometimes read) should go through the manager:
 	  (thunk)
-	  (sleep SLEEP-TIME)
+          (sync (system-idle-evt))
 	  (test (not runs?) thread-running? th)
 	  (test (make-bytes 10 66) read-bytes 10 in)
 	  (thread-wait th)
@@ -368,7 +370,7 @@
 (define (delay-hello)
   (let-values ([(r w) (make-pipe)])
     (thread (lambda ()
-	      (sleep 0.1)
+	      (sync (system-idle-evt))
 	      (write-string "hello" w)
 	      (close-output-port w)))
     r))
@@ -460,7 +462,7 @@
       (let* ([v #f]
 	     [t (thread (lambda ()
 			  (set! v (read-bytes 6 p))))])
-	(test #f sync/timeout SLEEP-TIME t)
+	(test (void) sync (system-idle-evt) t)
 	(display "56" out)
 	(test t sync/timeout SLEEP-TIME t)
 	(test #"123456" values v)))))

collects/tests/mzscheme/prompt-tests.ss

@@ -1650,7 +1650,7 @@
   (let ([t (thread (lambda () (long-loop void)))])
     (sleep 0.05)
     (break-thread t)
-    (sleep)
+    (sleep 0.05)
     (test #f thread-running? t))
   (printf "Trying long chain...\n")
   (let ([k (long-loop (lambda () 

collects/tests/mzscheme/quiet.ss

@@ -16,10 +16,8 @@
       (namespace-set-variable-value! 'real-error-port err)
       (namespace-set-variable-value! 'last-error #f)
       ;; we're loading this for the first time:
-      ;; -- make real errors show
+      ;; make real errors show by remembering the exn
-      ;;    (can't override current-exception-handler alone, since the escape
+      ;; value, and then printing it on abort.
-      ;;     handler is overridden to avoid running off, so use the first to
-      ;;     save the data and the second to show it)
       (uncaught-exception-handler (lambda (e) 
                                     (when (eq? (current-thread) orig-thread)
                                       (set! last-error e))
@@ -43,7 +41,8 @@
    (default-continuation-prompt-tag)
    (lambda (thunk)
      (when last-error
-       (fprintf real-error-port "ERROR: ~a\n"
+       (fprintf real-error-port "~aERROR: ~a\n"
+                Section-prefix
                 (if (exn? last-error) (exn-message last-error) last-error))
        (exit 2))))
   (report-errs #t))

collects/tests/mzscheme/sync.ss

@@ -291,56 +291,56 @@
   (let ([v #f])
     (test #f sync/timeout 0
 	  (nack-guard-evt (lambda (nack) 
-				      (set! v nack)
+                            (set! v nack)
-				      (make-semaphore))))
+                            (make-semaphore))))
     (test #t nack-try-wait? v)
     (set! v #f)
     (test #f sync/timeout SYNC-SLEEP-DELAY
 	  (nack-guard-evt (lambda (nack) 
-				      (set! v nack)
+                            (set! v nack)
-				      (make-semaphore))))
+                            (make-semaphore))))
     (test #t nack-try-wait? v)
     (set! v #f)
     (test #f sync/timeout 0
 	  (nack-guard-evt (lambda (nack) 
-				      (set! v nack)
+                            (set! v nack)
-				      (make-semaphore)))
+                            (make-semaphore)))
 	  (nack-guard-evt (lambda (nack) 
-				      (set! v nack)
+                            (set! v nack)
-				      (make-semaphore))))
+                            (make-semaphore))))
     (test #t nack-try-wait? v)
     (set! v #f)
     (test #f sync/timeout SYNC-SLEEP-DELAY
 	  (nack-guard-evt (lambda (nack) 
-				      (set! v nack)
+                            (set! v nack)
-				      (make-semaphore)))
+                            (make-semaphore)))
 	  (nack-guard-evt (lambda (nack) 
-				      (set! v nack)
+                            (set! v nack)
-				      (make-semaphore))))
+                            (make-semaphore))))
     (test #t nack-try-wait? v)
     (set! v #f)
     (test #f sync/timeout SYNC-SLEEP-DELAY
 	  (choice-evt 
 	   (nack-guard-evt (lambda (nack) 
-				       (set! v nack)
+                             (set! v nack)
-				       (make-semaphore)))
+                             (make-semaphore)))
 	   (nack-guard-evt (lambda (nack) 
-				       (set! v nack)
+                             (set! v nack)
-				       (make-semaphore)))))
+                             (make-semaphore)))))
     (test #t nack-try-wait? v)
     (set! v #f)
     (test s sync/timeout 0
 	  (nack-guard-evt (lambda (nack) 
-				      (set! v nack)
+                            (set! v nack)
-				      s)))
+                            s)))
     (test #f nack-try-wait? v) ; ... but not an exception!
     (semaphore-post s)
     (set! v #f)
     (let loop ()
       (test s sync/timeout 0
 	    (nack-guard-evt (lambda (nack) 
-					(set! v nack)
+                              (set! v nack)
-					(make-semaphore)))
+                              (make-semaphore)))
 	    s)
       (if v
 	  (test #t nack-try-wait? v)
@@ -503,13 +503,11 @@
       (semaphore-post sema)
       (let ()
 	(define (non-busy-wait waitable get-result)
-	  (check-busy-wait
+          (begin
-	   (lambda ()
+            (thread (lambda ()
-	     (thread (lambda ()
+                      (sync (system-idle-evt))
-		       (sleep SYNC-BUSY-DELAY)
+                      (semaphore-post sema)))
-		       (semaphore-post sema)))
+            (test (get-result) sync waitable))
-	     (test (get-result) sync waitable))
-	   #f)
 	  (test #f sync/timeout 0 waitable)
 	  (semaphore-post sema)
 	  (test (get-result) sync waitable)

collects/tests/mzscheme/testing.ss

@@ -59,8 +59,11 @@ transcript.
     (display msg err)
     (flush-output err)))
 
+(define Section-prefix
+  (namespace-variable-value 'Section-prefix #f (lambda () "")))
+
 (define (Section . args)
-  (eprintf* "Section~s\n" args)
+  (eprintf* "~aSection~s\n" Section-prefix args)
   (set! cur-section args)
   #t)
 
@@ -113,7 +116,7 @@ transcript.
 (define thunk-error-test
   (case-lambda
    [(th expr) (thunk-error-test th expr exn:application:type?)]
-   [(th expr exn?)
+   [(th expr exn-type?)
     (set! expr (syntax-object->datum expr))
     (set! number-of-error-tests (add1 number-of-error-tests))
     (printf "~s  =e=> " expr)
@@ -123,7 +126,7 @@ transcript.
 		      [orig-err-port (current-error-port)]
 		      [test-exn-handler
 		       (lambda (e)
-			 (when (and exn? (not (exn? e)))
+			 (when (and exn-type? (not (exn-type? e)))
 			       (printf " WRONG EXN TYPE: ~s " e)
 			       (record-error (list e 'exn-type expr)))
 			 (when (and (exn:fail:syntax? e)
@@ -173,7 +176,7 @@ transcript.
 (defvar error-test
   (case-lambda
     [(expr) (error-test expr exn:application:type?)]
-    [(expr exn?) (thunk-error-test (lambda () (eval expr)) expr exn?)]))
+    [(expr exn-type?) (thunk-error-test (lambda () (eval expr)) expr exn-type?)]))
 
 (require (rename mzscheme err:mz:lambda lambda)) ; so err/rt-test works with beginner.ss
 (define-syntax err/rt-test
@@ -231,7 +234,9 @@ transcript.
 		  (let ([v (with-handlers ([void
 					    (lambda (exn)
 					      (if (check? exn)
-						  (printf " ~a\n" (exn-message exn))
+						  (printf " ~a\n" (if (exn? exn)
+                                                                      (exn-message exn)
+                                                                      (format "uncaught ~x" exn)))
 						  (let ([ok-type? (exn:application:arity? exn)])
 						    (printf " WRONG EXN ~a: ~s\n"
 							    (if ok-type?

collects/tests/mzscheme/thread.ss

@@ -134,7 +134,7 @@
 				 (lambda ()
 				   (let loop ()
 				     (let ([r (set-ready #f)])
-				       (sleep SLEEP-TIME)
+				       (sync (system-idle-evt))
 				       (set! result (add1 result))
 				       (when r (semaphore-post r)))
 				     (loop)))))))))))
@@ -156,7 +156,7 @@
 (set! start result)
 (test #f thread-running? th1)
 (test #t thread-dead? th1)
-(sleep SLEEP-TIME)
+(sync (system-idle-evt))
 (test #t eq? start result)
 
 (let ([kept-going? #f])
@@ -285,12 +285,27 @@
 	(semaphore-wait s2) (semaphore-wait s2)
 	'ok))
 
+;; Returns a list of semaphores that are posted, in order,
+;;  when there's no work to do.
+(define (virtual-clock n-ticks)
+  (let ([semas (let loop ([n n-ticks])
+                 (if (zero? n)
+                     null
+                     (cons (make-semaphore) (loop (sub1 n)))))])
+    (thread (lambda ()
+              (let loop ([semas semas])
+                (unless (null? semas)
+                  (sync (system-idle-evt))
+                  (semaphore-post (car semas))
+                  (loop (cdr semas))))))
+    (map semaphore-peek-evt semas)))
+
 ; Tests inspired by a question from David Tillman
 (define (read-line/expire1 port expiration)
   (with-handlers ([exn:break? (lambda (exn) #f)])
     (let ([timer (thread (let ([id (current-thread)])
 			   (lambda () 
-			     (sleep expiration)
+			     (sync expiration)
 			     (break-thread id))))])
       (dynamic-wind
        void
@@ -303,7 +318,7 @@
 			(set! result (read-line port))
 			(semaphore-post done)))]
 	  [t2 (thread (lambda () 
-			(sleep expiration)
+			(sync expiration)
 			(semaphore-post done)))])
       (semaphore-wait done)
       (kill-thread t1)
@@ -323,6 +338,7 @@
       v)))
 
 (define (go read-line/expire)
+  (define clock (virtual-clock 3))
   (define p (let ([c 0]
 		  [nl-sema (make-semaphore 1)]
 		  [ready? #f]
@@ -340,7 +356,7 @@
 				(semaphore-try-wait? nl-sema)
 				(set! ready? #f)
 				(thread (lambda ()
-					  (sleep 0.4)
+					  (sync (cadr clock))
 					  (set! ready? #t)
 					  (semaphore-post nl-sema)))
 				(set! c (add1 c))
@@ -354,8 +370,8 @@
 		       0)))
 	       #f
 	       void)))
-  (test #f read-line/expire p 0.2) ; should get char but not newline
+  (test #f read-line/expire p (car clock)) ; should get char but not newline
-  (test "" read-line/expire p 0.6)) ; picks up newline
+  (test "" read-line/expire p (caddr clock))) ; picks up newline
 
 (go read-line/expire1)
 (go read-line/expire2)
@@ -556,9 +572,9 @@
 		     (lambda ()
 		       (with-handlers ([exn:break? (lambda (x) (set! v 'break))])
 			 (set! v (wait #f s t l r)))))])
-	    (sleep 0.05) ;;;     <---------- race condition (that's unlikely to fail)
+	    (sync (system-idle-evt))
 	    (break-thread bt)
-	    (sleep 0.05) ;;;     <----------
+            (sync (system-idle-evt))
 	    )
 	  (test 'break 'broken-wait v)))
 
@@ -678,7 +694,7 @@
 		      (test #f thread-running? t)
 		      (test #f thread-dead? t)
 		      (semaphore-post s)
-		      (sleep SLEEP-TIME)
+		      (sync (system-idle-evt))
 		      (test 17 values v)
 		      (thread-resume t)))])
     (semaphore-wait s)
@@ -689,7 +705,7 @@
 (let ([v 19]
       [t (current-thread)])
   (let ([t2 (thread (lambda () 
-		      (sleep SLEEP-TIME)
+                      (sync (system-idle-evt))
 		      (test 19 values v)
 		      (thread-resume t)))])
     (thread-suspend t)
@@ -744,7 +760,7 @@
 	      (let ([t2 (parameterize ([current-error-port /dev/null-for-err])
 			  (thread
 			   (lambda () 
-			     (let loop () (when (= v 10) (sleep) (loop)))
+			     (let loop () (when (= v 10) (sleep 0.01) (loop)))
 			     (sleep0)
 			     (set! v 99))))])
 		(sleep1)
@@ -838,7 +854,6 @@
 		     (w-block (lambda () (thread (lambda () (channel-put ch 10))))
 			      (lambda () (sync/timeout/enable-break #f (make-semaphore) ch))))))
 	       '(#t #f))))])
-     (define BKT-SLEEP-TIME (/ SLEEP-TIME 4))
      (goes void void break-thread)
      (goes void void kill-thread)
      (goes sleep void break-thread)
@@ -847,12 +862,12 @@
      (goes void sleep kill-thread)
      (goes sleep sleep break-thread)
      (goes sleep sleep kill-thread)
-     (goes (lambda () (sleep BKT-SLEEP-TIME)) void break-thread)
+     (goes (lambda () (sync (system-idle-evt))) void break-thread)
-     (goes (lambda () (sleep BKT-SLEEP-TIME)) void kill-thread)
+     (goes (lambda () (sync (system-idle-evt))) void kill-thread)
-     (goes void (lambda () (sleep BKT-SLEEP-TIME)) break-thread)
+     (goes void (lambda () (sync (system-idle-evt))) break-thread)
-     (goes void (lambda () (sleep BKT-SLEEP-TIME)) kill-thread)
+     (goes void (lambda () (sync (system-idle-evt))) kill-thread)
-     (goes (lambda () (sleep BKT-SLEEP-TIME)) (lambda () (sleep BKT-SLEEP-TIME)) break-thread)
+     (goes (lambda () (sync (system-idle-evt))) (lambda () (sync (system-idle-evt))) break-thread)
-     (goes (lambda () (sleep BKT-SLEEP-TIME)) (lambda () (sleep BKT-SLEEP-TIME)) kill-thread)))
+     (goes (lambda () (sync (system-idle-evt))) (lambda () (sync (system-idle-evt))) kill-thread)))
  (list sleep void))
 
 ;; ----------------------------------------
@@ -895,11 +910,20 @@
 ;; Kill versus Suspend
 
 (let* ([v 0]
+       [all-ticks (virtual-clock 40)]
+       [odd-ticks (let loop ([all-ticks all-ticks][get? #f])
+                    (if (null? all-ticks)
+                        null
+                        (if get?
+                            (cons (car all-ticks)
+                                  (loop (cdr all-ticks) #f))
+                            (loop (cdr all-ticks) #t))))]
        [loop (lambda ()
 	       (let loop ()
 		 (set! v (add1 v))
-		 (sleep (/ SLEEP-TIME 2))
+		 (sync (car all-ticks))
-		 (loop)))]
+                 (set! all-ticks (cdr all-ticks))
+                 (loop)))]
        [c0 (make-custodian)])
   (let ([try
 	 (lambda (resumable?)
@@ -909,7 +933,8 @@
 		       ((if resumable? thread/suspend-to-kill thread) loop))]
 		  [check-inc (lambda (inc?)
 			       (let ([v0 v]) 
-				 (sleep SLEEP-TIME)
+                                 (sync (car odd-ticks))
+                                 (set! odd-ticks (cdr odd-ticks))
 				 (test inc? > v v0)))])
 	     (test #t thread-running? t)
 	     (check-inc #t)
@@ -1222,6 +1247,10 @@
 ;; --------------------
 ;; Check BEGIN_ESCAPABLE:
 
+;; Races conditions due to the `sleep' calls here are ok. The
+;; intended order will happen often enough for the text to be
+;; useful.
+
 (let ([try
        (lambda (break? kill?)
          (let ([t (parameterize ([current-directory (or (current-load-relative-directory)

collects/tests/mzscheme/threadlib.ss

@@ -56,6 +56,8 @@
 
 ;; coroutines ----------------------------------------
 
+(define MAX-RUN-TIME 100) ; in msecs
+
 (define cntr 0)
 (define w (coroutine (lambda (enable-stop)
 		       (let loop ((i 0))
@@ -65,7 +67,7 @@
 			 (loop (add1 i))))))
 (test #t coroutine? w)
 (test #f coroutine-result w)
-(test #f coroutine-run 0.1 w)
+(test #f coroutine-run MAX-RUN-TIME w)
 (test #t positive? cntr)
 (test (void) coroutine-kill w)
 (test #t coroutine-run 100 w)
@@ -79,13 +81,13 @@
 			    (set! cntr i)
 			    (enable-stop #t)
 			    (loop (sub1 i))))))))
-(test #t coroutine-run 0.1 w2)
+(test #t coroutine-run MAX-RUN-TIME w2)
 (test 13 coroutine-result w2)
 (test #t coroutine-run 100 w2)
 
 (define w3 (coroutine (lambda (enable-stop)
 			(raise 14))))
-(err/rt-test (coroutine-run 0.1 w3) (lambda (x) (eq? x 14)))
+(err/rt-test (coroutine-run MAX-RUN-TIME w3) (lambda (x) (eq? x 14)))
 (test #f coroutine-result w3)
 (test #t coroutine-run 100 w3)
 
@@ -93,5 +95,5 @@
 			(enable-stop #f)
 			(raise 15))))
 (test #f coroutine-result w4)
-(err/rt-test (coroutine-run 0.1 w4) (lambda (x) (eq? x 15)))
+(err/rt-test (coroutine-run MAX-RUN-TIME w4) (lambda (x) (eq? x 15)))
 (test #t coroutine-run 100 w4)

collects/texpict/symbol.ss

@@ -1,7 +1,7 @@
 (module symbol (lib "slideshow.ss" "slideshow")
   
   (provide symbol
-	   sym:in sym:rightarrow sym:infinity sym:times 
+	   sym:in sym:rightarrow sym:leftarrow sym:infinity sym:times 
 	   sym:implies sym:emdash 
 	   sym:therefore)
   

doc/release-notes/mzscheme/HISTORY

@@ -1,3 +1,6 @@
+Version 369.7
+Added string->path-element and path-element->string
+
 Version 369.6
 Default load handler enables #reader (even when not reading a module)
 

src/mzscheme/gc2/compact.c

@@ -2781,8 +2781,6 @@ static void check_ptr(void **a)
 #endif
   }
 }
-# endif
-
 
 #define GC_X_variable_stack GC_do_check_variable_stack
 #define gcX(a) check_ptr(a)
@@ -2792,6 +2790,8 @@ static void check_ptr(void **a)
 #undef gcX
 #undef X_source
 
+# endif
+
 void GC_check_variable_stack()
 {
 # if CHECK_STACK_PTRS

src/mzscheme/gc2/weak.c

@@ -63,9 +63,9 @@ static int mark_weak_array(void *p)
     data = a->data;
     for (i = a->count; i--; ) {
       if (data[i] 
-	  && (*(short *)(data[i]) != 47)
 	  && (*(short *)(data[i]) != 48)
-	  && (*(short *)(data[i]) != 57)) {
+	  && (*(short *)(data[i]) != 49)
+	  && (*(short *)(data[i]) != 58)) {
 	CRASH(1);
       }
     }

src/mzscheme/src/char.c

@@ -258,7 +258,7 @@ Scheme_Object *scheme_make_char(mzchar ch)
   if (ch < 256)
     return scheme_char_constants[ch];
   
-  o = scheme_malloc_small_atomic_tagged(sizeof(Scheme_Simple_Object));
+  o = scheme_malloc_small_atomic_tagged(sizeof(Scheme_Small_Object));
   CLEAR_KEY_FIELD(o);
   o->type = scheme_char_type;
   SCHEME_CHAR_VAL(o) = ch;

src/mzscheme/src/env.c

@@ -1356,6 +1356,7 @@ static Scheme_Object *make_toplevel(mzshort depth, int position, int resolved, i
 {
   Scheme_Toplevel *tl;
   Scheme_Object *v, *pr;
+  Scheme_Hash_Table *tl_ht;
 
   /* Important: non-resolved can't be cached, because the ISCONST
      field is modified to track mutated module-level variables. But
@@ -1372,7 +1373,10 @@ static Scheme_Object *make_toplevel(mzshort depth, int position, int resolved, i
 			     scheme_make_integer(flags))
 	  : scheme_make_integer(position));
     pr = scheme_make_pair(scheme_make_integer(depth), pr);
-    v = scheme_hash_get(toplevels_ht, pr);
+    tl_ht = toplevels_ht;
+    scheme_wait_sema(tl_ht->mutex, 0);
+    v = scheme_hash_get(tl_ht, pr);
+    scheme_post_sema(tl_ht->mutex);
     if (v)
       return v;
   } else
@@ -1388,7 +1392,10 @@ static Scheme_Object *make_toplevel(mzshort depth, int position, int resolved, i
     if (toplevels_ht->count > TABLE_CACHE_MAX_SIZE) {
       toplevels_ht = scheme_make_hash_table_equal();
     }
-    scheme_hash_set(toplevels_ht, pr, (Scheme_Object *)tl);
+    tl_ht = toplevels_ht;
+    scheme_wait_sema(tl_ht->mutex, 0);
+    scheme_hash_set(tl_ht, pr, (Scheme_Object *)tl);
+    scheme_post_sema(tl_ht->mutex);
   }
 
   return (Scheme_Object *)tl;

src/mzscheme/src/eval.c

@@ -162,7 +162,6 @@ static Scheme_Object *top_expander;
 static Scheme_Object *stop_expander;
 
 static Scheme_Object *quick_stx;
-static int quick_stx_in_use;
 static int taking_shortcut;
 
 Scheme_Object *scheme_stack_dump_key;
@@ -497,7 +496,6 @@ scheme_init_eval (Scheme_Env *env)
 			    env);
 
   REGISTER_SO(quick_stx);
-  quick_stx = scheme_datum_to_syntax(app_symbol, scheme_false, scheme_false, 0, 0);
 }
 
 /*========================================================================*/
@@ -4000,7 +3998,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
 			   Scheme_Compile_Expand_Info *rec, int drec, 
 			   int app_position)
 {
-  Scheme_Object *name, *var, *stx, *normal;
+  Scheme_Object *name, *var, *stx, *normal, *can_recycle_stx = NULL;
   Scheme_Env *menv = NULL;
   GC_CAN_IGNORE char *not_allowed;
   int looking_for_top;
@@ -4239,13 +4237,16 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
   }
 
   /* Compile/expand as application, datum, or top: */
-  if (!quick_stx_in_use && rec[drec].comp) {
+  if (quick_stx && rec[drec].comp) {
-    quick_stx_in_use = 1;
     ((Scheme_Stx *)quick_stx)->val = stx;
     ((Scheme_Stx *)quick_stx)->wraps = ((Scheme_Stx *)form)->wraps;
+    ((Scheme_Stx *)quick_stx)->u.modinfo_cache = NULL;
     stx = quick_stx;
+    quick_stx = NULL;
   } else
     stx = scheme_datum_to_syntax(stx, scheme_false, form, 0, 0);
+  if (rec[drec].comp)
+    can_recycle_stx = stx;
 
   {
     Scheme_Object *find_name = stx;
@@ -4277,12 +4278,9 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
     }
   }
 
-  if (SAME_OBJ(stx, quick_stx)) {
+  if (!SAME_OBJ(var, normal)) {
-    quick_stx_in_use = 0;
+    /* Someone might keep the stx: */
-    if (!SAME_OBJ(var, normal)) {
+    can_recycle_stx = NULL;
-      /* Need a new stx after all: */
-      stx = scheme_datum_to_syntax(SCHEME_STX_VAL(stx), scheme_false, form, 0, 0);
-    }
   }
 
   if (!var && looking_for_top) {
@@ -4317,6 +4315,8 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
       Scheme_Syntax *f;
       taking_shortcut = 1;
       f = (Scheme_Syntax *)SCHEME_SYNTAX(var);
+      if (can_recycle_stx && !quick_stx)
+        quick_stx = can_recycle_stx;
       return f(form, env, rec, drec);
     } else {
       form = scheme_datum_to_syntax(scheme_make_immutable_pair(stx, form), form, form, 0, 2);
@@ -4411,11 +4411,13 @@ compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env,
 		   Scheme_Compile_Expand_Info *rec, int drec)
 {
   Scheme_Object *form, *naya;
+  int tsc = taking_shortcut;
+
+  taking_shortcut = 0;
 
   scheme_rec_add_certs(rec, drec, forms);
-  if (taking_shortcut) {
+  if (tsc) {
     form = forms;
-    taking_shortcut = 0;
   } else {
     form = SCHEME_STX_CDR(forms);
     form = scheme_datum_to_syntax(form, forms, forms, 0, 0);

src/mzscheme/src/file.c

@@ -154,9 +154,11 @@ static Scheme_Object *general_path_p(int argc, Scheme_Object **argv);
 static Scheme_Object *path_to_string(int argc, Scheme_Object **argv);
 static Scheme_Object *path_to_bytes(int argc, Scheme_Object **argv);
 static Scheme_Object *path_element_to_bytes(int argc, Scheme_Object **argv);
+static Scheme_Object *path_element_to_string(int argc, Scheme_Object **argv);
 static Scheme_Object *string_to_path(int argc, Scheme_Object **argv);
 static Scheme_Object *bytes_to_path(int argc, Scheme_Object **argv);
 static Scheme_Object *bytes_to_path_element(int argc, Scheme_Object **argv);
+static Scheme_Object *string_to_path_element(int argc, Scheme_Object **argv);
 static Scheme_Object *path_kind(int argc, Scheme_Object **argv);
 static Scheme_Object *platform_path_kind(int argc, Scheme_Object **argv);
 
@@ -312,6 +314,11 @@ void scheme_init_file(Scheme_Env *env)
 						      "path-element->bytes", 
 						      1, 1), 
 			     env);
+  scheme_add_global_constant("path-element->string", 
+			     scheme_make_prim_w_arity(path_element_to_string, 
+						      "path-element->string", 
+						      1, 1), 
+			     env);
   scheme_add_global_constant("string->path", 
 			     scheme_make_prim_w_arity(string_to_path, 
 						      "string->path", 
@@ -327,6 +334,11 @@ void scheme_init_file(Scheme_Env *env)
 						      "bytes->path-element", 
 						      1, 2), 
 			     env);
+  scheme_add_global_constant("string->path-element", 
+			     scheme_make_prim_w_arity(string_to_path_element, 
+						      "string->path-element", 
+						      1, 1), 
+			     env);
 
   scheme_add_global_constant("file-exists?", 
 			     scheme_make_prim_w_arity(file_exists, 
@@ -760,10 +772,6 @@ Scheme_Object *scheme_path_to_char_string(Scheme_Object *p)
 {
   Scheme_Object *s;
 
-#ifdef DOS_FILE_SYSTEM
-  p = drop_rel_prefix(p);
-#endif
-
   s = scheme_byte_string_to_char_string_locale(p);
 
   if (!SCHEME_CHAR_STRLEN_VAL(s))
@@ -801,28 +809,29 @@ static Scheme_Object *is_path_element(Scheme_Object *p)
                          &isdir,
                          SCHEME_PATH_KIND(p));
 
-  if (SCHEME_SYMBOLP(base))
+  if (SCHEME_SYMBOLP(base)
+      && SCHEME_GENERAL_PATHP(fn))
     return fn;
   return NULL;
 }
 
-static Scheme_Object *path_element_to_bytes(int argc, Scheme_Object **argv)
+static Scheme_Object *do_path_element_to_bytes(const char *name, int argc, Scheme_Object **argv)
 {
   Scheme_Object *p = argv[0], *pe;
   int kind;
 
   if (!SCHEME_GENERAL_PATHP(p))
-    scheme_wrong_type("path-element->bytes", "path", 0, argc, argv);
+    scheme_wrong_type(name, "path", 0, argc, argv);
   
   pe = is_path_element(p);
 
   if (!pe)
-    scheme_arg_mismatch("path-element->bytes",
+    scheme_arg_mismatch(name,
                         "path can be split or is not relative: ",
                         p);
 
   if (SCHEME_SYMBOLP(pe)) {
-    scheme_arg_mismatch("path-element->bytes",
+    scheme_arg_mismatch(name,
                         (SAME_OBJ(pe, up_symbol)
                          ? "path is an up-directory indicator: "
                          : "path is a same-directory indicator: "),
@@ -853,6 +862,18 @@ static Scheme_Object *path_element_to_bytes(int argc, Scheme_Object **argv)
 				       1);
 }
 
+static Scheme_Object *path_element_to_bytes(int argc, Scheme_Object **argv)
+{
+  return do_path_element_to_bytes("path-element->bytes", argc, argv);
+}
+
+static Scheme_Object *path_element_to_string(int argc, Scheme_Object **argv)
+{
+  Scheme_Object *b;
+  b = do_path_element_to_bytes("path-element->string", argc, argv);
+  return scheme_byte_string_to_char_string_locale(b);
+}
+
 static void check_path_ok(const char *who, Scheme_Object *p, Scheme_Object *o)
 {
   if (has_null(SCHEME_PATH_VAL(p), SCHEME_PATH_LEN(p))) {
@@ -907,15 +928,15 @@ static Scheme_Object *bytes_to_path(int argc, Scheme_Object **argv)
   return s;
 }
 
-static Scheme_Object *bytes_to_path_element(int argc, Scheme_Object **argv)
+static Scheme_Object *do_bytes_to_path_element(const char *name, Scheme_Object *s, int argc, Scheme_Object **argv)
 {
-  Scheme_Object *s = argv[0], *p;
+  Scheme_Object *p;
   long i, len;
   int kind;
 
   if (!SCHEME_BYTE_STRINGP(s))
-    scheme_wrong_type("bytes->path-element", "byte string", 0, argc, argv);
+    scheme_wrong_type(name, "byte string", 0, argc, argv);
-  kind = extract_path_kind("bytes->path-element", 1, argc, argv);
+  kind = extract_path_kind(name, 1, argc, argv);
 
   len = SCHEME_BYTE_STRLEN_VAL(s);
   for (i = 0; i < len; i++) {
@@ -933,13 +954,30 @@ static Scheme_Object *bytes_to_path_element(int argc, Scheme_Object **argv)
     p = NULL;
 
   if (!p || !is_path_element(p))
-    scheme_arg_mismatch("bytes->path-element",
+    scheme_arg_mismatch(name,
-                        "converted path can be split or is not relative: ",
+                        "cannot be converted to a path element (can be split, is not relative, or names a special element): ",
                         argv[0]);
 
   return p;
 }
 
+static Scheme_Object *bytes_to_path_element(int argc, Scheme_Object **argv)
+{
+  return do_bytes_to_path_element("bytes->path-element", argv[0], argc, argv);
+}
+
+static Scheme_Object *string_to_path_element(int argc, Scheme_Object **argv)
+{
+  Scheme_Object *b;
+
+  if (!SCHEME_CHAR_STRINGP(argv[0]))
+    scheme_wrong_type("string->path-element", "string", 0, argc, argv);
+
+  b = scheme_char_string_to_byte_string_locale(argv[0]);
+  
+  return do_bytes_to_path_element("string->path-element", b, argc, argv);
+}
+
 /**********************************************************************/
 /*                                                                    */
 /**********************************************************************/

src/mzscheme/src/number.c

@@ -684,7 +684,8 @@ Scheme_Object *scheme_make_float(float f)
 {
   Scheme_Float *sf;
 
-  sf = (Scheme_Float *)scheme_malloc_atomic_tagged(sizeof(Scheme_Float));
+  sf = (Scheme_Float *)scheme_malloc_small_atomic_tagged(sizeof(Scheme_Float));
+  CLEAR_KEY_FIELD(&sf->so);
   sf->so.type = scheme_float_type;
   SCHEME_FLT_VAL(sf) = f;
   return (Scheme_Object *)sf;

src/mzscheme/src/portfun.c

@@ -2292,13 +2292,15 @@ static int pipe_out_ready(Scheme_Output_Port *p)
   if (pipe->eof || !pipe->bufmax)
     return 1;
 
-  if (pipe->bufstart <= pipe->bufend) {
+  if (pipe->bufend >= pipe->bufstart) {
-    avail = (pipe->buflen - pipe->bufend) + pipe->bufstart - 1;
+    avail = pipe->bufend - pipe->bufstart;
   } else {
-    avail = pipe->bufstart - pipe->bufend - 1;
+    avail = pipe->bufend + (pipe->buflen - pipe->bufstart);
   }
 
-  return !!avail;
+  avail = pipe->bufmax + pipe->bufmaxextra - 1 - avail;
+
+  return avail > 0;
 }
 
 void scheme_pipe_with_limit(Scheme_Object **read, Scheme_Object **write, int queuelimit)

src/mzscheme/src/schminc.h

@@ -11,9 +11,9 @@
    EXPECTED_PRIM_COUNT to the new value, and then USE_COMPILED_STARTUP
    can be set to 1 again. */
 
-#define USE_COMPILED_STARTUP 0
+#define USE_COMPILED_STARTUP 1
 
-#define EXPECTED_PRIM_COUNT 888
+#define EXPECTED_PRIM_COUNT 890
 
 #ifdef MZSCHEME_SOMETHING_OMITTED
 # undef USE_COMPILED_STARTUP

src/mzscheme/src/schvers.h

@@ -9,6 +9,6 @@
 
 
 #define MZSCHEME_VERSION_MAJOR 369
-#define MZSCHEME_VERSION_MINOR 6
+#define MZSCHEME_VERSION_MINOR 7
 
-#define MZSCHEME_VERSION "369.6" _MZ_SPECIAL_TAG
+#define MZSCHEME_VERSION "369.7" _MZ_SPECIAL_TAG

src/mzscheme/src/string.c

@@ -938,8 +938,8 @@ long scheme_extract_index(const char *name, int pos, int argc, Scheme_Object **a
 }
 
 void scheme_get_substring_indices(const char *name, Scheme_Object *str,
-				  int argc, Scheme_Object **argv,
+                                  int argc, Scheme_Object **argv,
-				  int spos, int fpos, long *_start, long *_finish)
+                                  int spos, int fpos, long *_start, long *_finish)
 {
   long len;
   long start, finish;
@@ -969,6 +969,36 @@ void scheme_get_substring_indices(const char *name, Scheme_Object *str,
   *_finish = finish;
 }
 
+static void get_substring_indices(const char *name, Scheme_Object *str,
+                                  int argc, Scheme_Object **argv,
+                                  int spos, int fpos, long *_start, long *_finish, long len)
+{
+  if (argc > spos) {
+    if (SCHEME_INTP(argv[spos])) {
+      long start = SCHEME_INT_VAL(argv[spos]);
+      if ((start >= 0) && (start < len)) {
+        *_start = start;
+        if (argc > fpos) {
+          long finish = SCHEME_INT_VAL(argv[fpos]);
+          if ((finish >= start) && (finish <= len)) {
+            *_finish = finish;
+            return;
+          }
+        } else {
+          *_finish = len;
+          return;
+        }
+      }
+    }
+  } else {
+    *_start = 0;
+    *_finish = len;
+    return;
+  }
+
+  return scheme_get_substring_indices(name, str, argc, argv, spos, fpos, _start, _finish);
+}
+
 /**********************************************************************/
 /*                          char strings                              */
 /**********************************************************************/
@@ -4868,6 +4898,7 @@ mzchar *scheme_utf8_decode_to_buffer_len(const unsigned char *s, int len,
 					 mzchar *buf, int blen, long *_ulen)
 {
   int ulen;
+
   ulen = utf8_decode_x(s, 0, len, NULL, 0, -1,
 		       NULL, NULL, 0, 0,
 		       NULL, 0, 0);
@@ -5089,6 +5120,22 @@ char *scheme_utf8_encode_to_buffer_len(const mzchar *s, int len,
 				       long *_slen)
 {
   int slen;
+
+  /* ASCII with len < blen is a common case: */
+  if (len < blen) {
+    for (slen = 0; slen < len; slen++) {
+      if (s[slen] > 127)
+        break;
+      else
+        buf[slen] = s[slen];
+    }
+    if (slen == len) {
+      buf[slen] = 0;
+      *_slen = slen;
+      return buf;
+    }
+  }
+
   slen = utf8_encode_x(s, 0, len, NULL, 0, -1, NULL, NULL, 0);
   if (slen + 1 > blen) {
     buf = (char *)scheme_malloc_atomic(slen + 1);

src/mzscheme/src/strops.inc

@@ -208,8 +208,8 @@ X__(substring) (int argc, Scheme_Object *argv[])
 
   chars = SCHEME_X_STR_VAL(argv[0]);
 
-  scheme_get_substring_indices(SUBXSTR, argv[0], argc, argv, 1, 2,
+  get_substring_indices(SUBXSTR, argv[0], argc, argv, 1, 2,
-			       &start, &finish);
+                        &start, &finish, SCHEME_X_STRTAG_VAL(argv[0]));
 
   str = X(scheme_alloc, _string)(finish-start, 0);
   memcpy(SCHEME_X_STR_VAL(str), chars + start, (finish - start) * sizeof(Xchar));
@@ -335,28 +335,31 @@ X__(string_copy) (int argc, Scheme_Object *argv[])
     scheme_wrong_type(XSTRINGSTR "-copy", XSTR "string", 0, argc, argv);
 
   return X(scheme_make_sized, _string)(SCHEME_X_STR_VAL(argv[0]), 
-					   SCHEME_X_STRTAG_VAL(argv[0]), 1);
+                                       SCHEME_X_STRTAG_VAL(argv[0]), 1);
 }
 
 static Scheme_Object *
 X__(string_copy_bang)(int argc, Scheme_Object *argv[])
 {
+  Scheme_Object *s1, *s2;
   long istart, ifinish;
   long ostart, ofinish;
 
-  if (!SCHEME_MUTABLE_X_STRINGP(argv[0]))
+  s1 = argv[0];
+  if (!SCHEME_MUTABLE_X_STRINGP(s1))
     scheme_wrong_type(XSTRINGSTR "-copy!", "mutable " XSTR "string", 0, argc, argv);
 
-  scheme_get_substring_indices(XSTRINGSTR "-copy!", argv[0], 
+  get_substring_indices(XSTRINGSTR "-copy!", s1, 
-			       argc, argv, 1, 5, 
+                        argc, argv, 1, 5, 
-			       &ostart, &ofinish);
+                        &ostart, &ofinish, SCHEME_X_STRTAG_VAL(s1));
 
-  if (!SCHEME_X_STRINGP(argv[0]))
+  s2 = argv[2];
+  if (!SCHEME_X_STRINGP(s2))
     scheme_wrong_type(XSTRINGSTR "-copy!", XSTR "string", 2, argc, argv);
 
-  scheme_get_substring_indices(XSTRINGSTR "-copy!", argv[2], 
+  get_substring_indices(XSTRINGSTR "-copy!", s2, 
-			       argc, argv, 3, 4, 
+                        argc, argv, 3, 4, 
-			       &istart, &ifinish);
+                        &istart, &ifinish, SCHEME_X_STRTAG_VAL(s2));
 
   if ((ofinish - ostart) < (ifinish - istart)) {
     scheme_arg_mismatch(XSTRINGSTR "-copy!",
@@ -365,8 +368,8 @@ X__(string_copy_bang)(int argc, Scheme_Object *argv[])
     return NULL;
   }
 
-  memmove(SCHEME_X_STR_VAL(argv[0]) + ostart,
+  memmove(SCHEME_X_STR_VAL(s1) + ostart,
-	  SCHEME_X_STR_VAL(argv[2]) + istart,
+	  SCHEME_X_STR_VAL(s2) + istart,
 	  (ifinish - istart) * sizeof(Xchar));
   
   return scheme_void;

src/mzscheme/src/symbol.c

@@ -82,6 +82,10 @@ typedef unsigned long hash_v_t;
 # define WEAK_ARRAY_HEADSIZE 0
 #endif
 
+static Scheme_Object *rehash_symbol_bucket(Scheme_Hash_Table *table,
+                                           GC_CAN_IGNORE const char *key, unsigned int length,
+                                           Scheme_Object *naya);
+
 /* Special hashing for symbols: */
 static Scheme_Object *symbol_bucket(Scheme_Hash_Table *table,
 				    GC_CAN_IGNORE const char *key, unsigned int length,
@@ -92,8 +96,9 @@ static Scheme_Object *symbol_bucket(Scheme_Hash_Table *table,
   Scheme_Object *bucket;
 
   /* WARNING: key may be GC-misaligned... */
+  /* This function is designed to need no MZ_PRECISE_GC instrumentation.
+     To handle re-hashing, it tail-calls rehash_symbol_bucket. */
 
- rehash_key:
   mask = table->size - 1;
 
   {
@@ -138,51 +143,7 @@ static Scheme_Object *symbol_bucket(Scheme_Hash_Table *table,
     return NULL;
 
   if (table->count * FILL_FACTOR >= table->size) {
-    /* Rehash */
+    return rehash_symbol_bucket(table, key, length, naya);
-    int i, oldsize = table->size, newsize, lostc;
-    size_t asize;
-    Scheme_Object *cb;
-    Scheme_Object **old = table->keys;
-
-    /* Don't grow table if it's mostly lost cells (due to lots of
-       temporary symbols). */
-    lostc = 0;
-    for (i = 0; i < oldsize; i++) {
-      cb = old[WEAK_ARRAY_HEADSIZE + i];
-      if (cb == SYMTAB_LOST_CELL)
-	lostc++;
-    }
-    if ((lostc * 2) < table->count)
-      newsize = oldsize << 1;
-    else
-      newsize = oldsize;
-
-    asize = (size_t)newsize * sizeof(Scheme_Object *);
-    {
-      Scheme_Object **ba;
-#ifdef MZ_PRECISE_GC
-      ba = (Scheme_Object **)GC_malloc_weak_array(sizeof(Scheme_Object *) * newsize,
-						  SYMTAB_LOST_CELL);
-#else
-      ba = MALLOC_N_ATOMIC(Scheme_Object *, newsize);
-      memset((char *)ba, 0, asize);
-#endif
-      table->keys = ba;
-    }
-    table->size = newsize;
-
-    table->count = 0;
-
-    for (i = 0; i < oldsize; i++) {
-      cb = old[WEAK_ARRAY_HEADSIZE + i] ;
-      if (cb && (cb != SYMTAB_LOST_CELL))
-	symbol_bucket(table, SCHEME_SYM_VAL(cb), SCHEME_SYM_LEN(cb), cb);
-    }
-
-    /* Restore GC-misaligned key: */
-    key = SCHEME_SYM_VAL(naya);
-
-    goto rehash_key;
   }
 
   table->keys[WEAK_ARRAY_HEADSIZE + h] = naya;
@@ -192,6 +153,58 @@ static Scheme_Object *symbol_bucket(Scheme_Hash_Table *table,
   return naya;
 }
 
+static Scheme_Object *rehash_symbol_bucket(Scheme_Hash_Table *table,
+                                           GC_CAN_IGNORE const char *key, unsigned int length,
+                                           Scheme_Object *naya)
+{
+  int i, oldsize = table->size, newsize, lostc;
+  size_t asize;
+  Scheme_Object *cb;
+  Scheme_Object **old = table->keys;
+
+  /* WARNING: key may be GC-misaligned... */
+
+  /* Don't grow table if it's mostly lost cells (due to lots of
+     temporary symbols). */
+  lostc = 0;
+  for (i = 0; i < oldsize; i++) {
+    cb = old[WEAK_ARRAY_HEADSIZE + i];
+    if (cb == SYMTAB_LOST_CELL)
+      lostc++;
+  }
+  if ((lostc * 2) < table->count)
+    newsize = oldsize << 1;
+  else
+    newsize = oldsize;
+
+  asize = (size_t)newsize * sizeof(Scheme_Object *);
+  {
+    Scheme_Object **ba;
+#ifdef MZ_PRECISE_GC
+    ba = (Scheme_Object **)GC_malloc_weak_array(sizeof(Scheme_Object *) * newsize,
+                                                SYMTAB_LOST_CELL);
+#else
+    ba = MALLOC_N_ATOMIC(Scheme_Object *, newsize);
+    memset((char *)ba, 0, asize);
+#endif
+    table->keys = ba;
+  }
+  table->size = newsize;
+
+  table->count = 0;
+
+  for (i = 0; i < oldsize; i++) {
+    cb = old[WEAK_ARRAY_HEADSIZE + i] ;
+    if (cb && (cb != SYMTAB_LOST_CELL))
+      symbol_bucket(table, SCHEME_SYM_VAL(cb), SCHEME_SYM_LEN(cb), cb);
+  }
+
+  /* Restore GC-misaligned key: */
+  key = SCHEME_SYM_VAL(naya);
+
+  return symbol_bucket(table, key, length, naya);
+}
+
 #ifndef MZ_PRECISE_GC
 static void clean_one_symbol_table(Scheme_Hash_Table *symbol_table)
 {

src/mzscheme/src/thread.c

@@ -357,6 +357,8 @@ static int dead_ready(Scheme_Object *o, Scheme_Schedule_Info *sinfo);
 
 static int can_break_param(Scheme_Thread *p);
 
+static int post_system_idle();
+
 static Scheme_Object *current_stats(int argc, Scheme_Object *args[]);
 
 static Scheme_Object **config_map;
@@ -2333,11 +2335,15 @@ static void select_thread()
       }
       if ((new_thread->running & MZTHREAD_USER_SUSPENDED)
 	  && !(new_thread->running & MZTHREAD_NEED_SUSPEND_CLEANUP)) {
-	scheme_console_printf("unbreakable deadlock\n");
+        if (post_system_idle()) {
-	if (scheme_exit)
+          /* Aha! Someone was waiting for us to do nothing. Try again... */
-	  scheme_exit(1);
+        } else {
-	/* We really have to exit: */
+          scheme_console_printf("unbreakable deadlock\n");
-	exit(1);
+          if (scheme_exit)
+            scheme_exit(1);
+          /* We really have to exit: */
+          exit(1);
+        }
       } else {
 	scheme_weak_resume_thread(new_thread);
       }
@@ -3204,6 +3210,9 @@ static int check_sleep(int need_activity, int sleep_now)
     if (needs_sleep_cancelled)
       return 0;
 
+    if (post_system_idle())
+      return 0;
+  
     if (sleep_now) {
       float mst = (float)max_sleep_time;
 
@@ -3222,16 +3231,16 @@ static int check_sleep(int need_activity, int sleep_now)
   return 0;
 }
 
-void scheme_cancel_sleep()
-{
-  needs_sleep_cancelled = 1;
-}
-
 static int post_system_idle()
 {
   return scheme_try_channel_get(scheme_system_idle_channel);
 }
 
+void scheme_cancel_sleep()
+{
+  needs_sleep_cancelled = 1;
+}
+
 void scheme_check_threads(void)
 /* Signals should be suspended. */
 {
@@ -3739,8 +3748,7 @@ void scheme_thread_block(float sleep_time)
   } else {
     /* If all processes are blocked, check for total process sleeping: */
     if (p->block_descriptor != NOT_BLOCKED) {
-      if (!post_system_idle())
+      check_sleep(1, 1);
-        check_sleep(1, 1);
     }
   }