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

369.7

Browse Source 
svn: r5506
This commit is contained in:
Matthew Flatt 2007-01-30 06:34:05 +00:00
parent 1668d9c036
commit bfc693c063
29 changed files with 2125 additions and 1932 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
collects/mzlib/port.ss
View File

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

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

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

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

@ -10,55 +10,77 @@
"quiet.ss"))])
(namespace-variable-value 'parallel-load))
(define (start x) (x))
;; Uncomment the following expression to have threads start with the
(define in-shared-k #f)
;; Some 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)])
(thread
(lambda ()
(start
(lambda ()
(parameterize ([current-namespace ns])
(namespace-transformer-require 'mzscheme)
(let ([dirname (format "sub~s" n)])
(when (directory-exists? dirname)
(delete-directory* dirname))
(make-directory dirname)
(current-directory dirname)
(dynamic-wind
void
(lambda ()
(load test))
(lambda ()
(semaphore-post done)
(semaphore-wait go)
(printf "~nThread ~s:" n)
(eval '(report-errs))
(current-directory (build-path 'up))
(delete-directory* dirname)
(semaphore-post done)))))))))
(loop (sub1 n)))))
(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))))))
(let ([ns (make-namespace)]
[eh (exit-handler)]
[cust (list-ref custodians (sub1 n))])
(parameterize ([current-custodian cust])
(thread
(lambda ()
(start
n
(lambda ()
(parameterize ([current-namespace ns]
[exit-handler (lambda (v)
(for-each (lambda (c)
(unless (eq? c cust)
(custodian-shutdown-all c)))
custodians)
(eh v))])
(namespace-transformer-require 'mzscheme)
(eval `(define Section-prefix ,(format "~a:" n)))
(let ([dirname (format "sub~s" n)])
(when (directory-exists? dirname)
(delete-directory* dirname))
(make-directory dirname)
(current-directory dirname)
(dynamic-wind
void
(lambda ()
(load test))
(lambda ()
(semaphore-post done)
(semaphore-wait go)
(printf "~nThread ~s:" n)
(eval '(report-errs))
(current-directory (build-path 'up))
(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)

10
collects/tests/mzscheme/path.ss
View File

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

3
collects/tests/mzscheme/port.ss
View File

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

30
collects/tests/mzscheme/portlib.ss
View File

@ -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)))))])
(sleep SLEEP-TIME)
(let ([evt (write-bytes-avail-evt #"x" out)])
(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)))))

2
collects/tests/mzscheme/prompt-tests.ss
View File

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

9
collects/tests/mzscheme/quiet.ss
View File

@ -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
;; (can't override current-exception-handler alone, since the escape
;; handler is overridden to avoid running off, so use the first to
;; save the data and the second to show it)
;; make real errors show by remembering the exn
;; value, and then printing it on abort.
(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))

52
collects/tests/mzscheme/sync.ss
View File

@ -291,56 +291,56 @@
(let ([v #f])
(test #f sync/timeout 0
(nack-guard-evt (lambda (nack)
(set! v nack)
(make-semaphore))))
(set! v nack)
(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)
(make-semaphore))))
(set! v nack)
(make-semaphore))))
(test #t nack-try-wait? v)
(set! v #f)
(test #f sync/timeout 0
(nack-guard-evt (lambda (nack)
(set! v nack)
(make-semaphore)))
(set! v nack)
(make-semaphore)))
(nack-guard-evt (lambda (nack)
(set! v nack)
(make-semaphore))))
(set! v nack)
(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)
(make-semaphore)))
(set! v nack)
(make-semaphore)))
(nack-guard-evt (lambda (nack)
(set! v nack)
(make-semaphore))))
(set! v nack)
(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)
(make-semaphore)))
(set! v nack)
(make-semaphore)))
(nack-guard-evt (lambda (nack)
(set! v nack)
(make-semaphore)))))
(set! v nack)
(make-semaphore)))))
(test #t nack-try-wait? v)
(set! v #f)
(test s sync/timeout 0
(nack-guard-evt (lambda (nack)
(set! v nack)
s)))
(set! v nack)
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)
(make-semaphore)))
(set! v nack)
(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
(lambda ()
(thread (lambda ()
(sleep SYNC-BUSY-DELAY)
(semaphore-post sema)))
(test (get-result) sync waitable))
#f)
(begin
(thread (lambda ()
(sync (system-idle-evt))
(semaphore-post sema)))
(test (get-result) sync waitable))
(test #f sync/timeout 0 waitable)
(semaphore-post sema)
(test (get-result) sync waitable)

15
collects/tests/mzscheme/testing.ss
View File

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

73
collects/tests/mzscheme/thread.ss
View File

@ -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 "" read-line/expire p 0.6)) ; picks up newline
(test #f read-line/expire p (car clock)) ; should get char but not 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 () (sleep BKT-SLEEP-TIME)) void kill-thread)
(goes void (lambda () (sleep BKT-SLEEP-TIME)) break-thread)
(goes void (lambda () (sleep BKT-SLEEP-TIME)) kill-thread)
(goes (lambda () (sleep BKT-SLEEP-TIME)) (lambda () (sleep BKT-SLEEP-TIME)) break-thread)
(goes (lambda () (sleep BKT-SLEEP-TIME)) (lambda () (sleep BKT-SLEEP-TIME)) kill-thread)))
(goes (lambda () (sync (system-idle-evt))) void break-thread)
(goes (lambda () (sync (system-idle-evt))) void kill-thread)
(goes void (lambda () (sync (system-idle-evt))) break-thread)
(goes void (lambda () (sync (system-idle-evt))) kill-thread)
(goes (lambda () (sync (system-idle-evt))) (lambda () (sync (system-idle-evt))) break-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))
(loop)))]
(sync (car all-ticks))
(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)

10
collects/tests/mzscheme/threadlib.ss
View File

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

2
collects/texpict/symbol.ss
View File

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

3
doc/release-notes/mzscheme/HISTORY
View File

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

4
src/mzscheme/gc2/compact.c
View File

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

4
src/mzscheme/gc2/weak.c
View File

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

2
src/mzscheme/src/char.c
View File

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

3378
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

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

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

28
src/mzscheme/src/eval.c
View File

@ -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) {
quick_stx_in_use = 1;
if (quick_stx && rec[drec].comp) {
((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)) {
quick_stx_in_use = 0;
if (!SAME_OBJ(var, normal)) {
/* Need a new stx after all: */
stx = scheme_datum_to_syntax(SCHEME_STX_VAL(stx), scheme_false, form, 0, 0);
}
if (!SAME_OBJ(var, normal)) {
/* Someone might keep the stx: */
can_recycle_stx = NULL;
}
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);

68
src/mzscheme/src/file.c
View File

@ -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);
kind = extract_path_kind("bytes->path-element", 1, argc, argv);
scheme_wrong_type(name, "byte string", 0, 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",
"converted path can be split or is not relative: ",
scheme_arg_mismatch(name,
"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);
}
/**********************************************************************/
/* */
/**********************************************************************/

3
src/mzscheme/src/number.c
View File

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

10
src/mzscheme/src/portfun.c
View File

@ -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) {
avail = (pipe->buflen - pipe->bufend) + pipe->bufstart - 1;
if (pipe->bufend >= pipe->bufstart) {
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)

4
src/mzscheme/src/schminc.h
View File

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

4
src/mzscheme/src/schvers.h
View File

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

51
src/mzscheme/src/string.c
View File

@ -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 spos, int fpos, long *_start, long *_finish)
int argc, Scheme_Object **argv,
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);

29
src/mzscheme/src/strops.inc
View File

@ -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,
&start, &finish);
get_substring_indices(SUBXSTR, argv[0], argc, argv, 1, 2,
&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],
argc, argv, 1, 5,
&ostart, &ofinish);
get_substring_indices(XSTRINGSTR "-copy!", s1,
argc, argv, 1, 5,
&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],
argc, argv, 3, 4,
&istart, &ifinish);
get_substring_indices(XSTRINGSTR "-copy!", s2,
argc, argv, 3, 4,
&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,
SCHEME_X_STR_VAL(argv[2]) + istart,
memmove(SCHEME_X_STR_VAL(s1) + ostart,
SCHEME_X_STR_VAL(s2) + istart,
(ifinish - istart) * sizeof(Xchar));
return scheme_void;

105
src/mzscheme/src/symbol.c
View File

@ -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 */
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;
return rehash_symbol_bucket(table, key, length, naya);
}
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)
{

32
src/mzscheme/src/thread.c
View File

@ -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 (scheme_exit)
scheme_exit(1);
/* We really have to exit: */
exit(1);
if (post_system_idle()) {
/* Aha! Someone was waiting for us to do nothing. Try again... */
} else {
scheme_console_printf("unbreakable deadlock\n");
if (scheme_exit)
scheme_exit(1);
/* We really have to exit: */
exit(1);
}
} else {
scheme_weak_resume_thread(new_thread);
}
@ -3203,6 +3209,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);
}
}