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

.

Browse Source 
original commit: a6413ec7a9c43f748e343f5cae96e21270861803
This commit is contained in:
Robby Findler 2004-06-21 22:01:15 +00:00
parent f885bcf355
commit daf0990c27
1 changed files with 72 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

113
collects/framework/private/text.ss
View File

@ -33,7 +33,9 @@ WARNING: printf is rebound in the body of the unit to always
(rename [-keymap% keymap%]) (rename [-keymap% keymap%])
(define original-output-port (current-output-port)) (define original-output-port (current-output-port))
(define (printf . args) (apply fprintf original-output-port args)) (define (printf . args)
;(apply fprintf original-output-port args)
(void))
(define-struct range (start end b/w-bitmap color caret-space?)) (define-struct range (start end b/w-bitmap color caret-space?))
(define-struct rectangle (left top right bottom b/w-bitmap color)) (define-struct rectangle (left top right bottom b/w-bitmap color))
@ -856,7 +858,7 @@ WARNING: printf is rebound in the body of the unit to always
get-err-port get-err-port
get-value-port)) get-value-port))
(define-struct peeker (bytes skip-count pe resp-chan nack)) (define-struct peeker (bytes skip-count pe resp-chan nack) (make-inspector))
(define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack)) (define-struct committer (kr commit-peeker-evt done-evt resp-chan resp-nack))
(define ports-mixin (define ports-mixin
@ -1210,12 +1212,13 @@ WARNING: printf is rebound in the body of the unit to always
;; loop : -> alpha ;; loop : -> alpha
;; the main loop for this thread ;; the main loop for this thread
(define (loop) (define (loop)
(printf "loop ~s\n" (queue->list data))
(let-values ([(not-ready-peekers new-peek-response-evts) (let-values ([(not-ready-peekers new-peek-response-evts)
(separate peekers service-waiter)] (separate peekers service-waiter)]
[(potential-commits new-commit-response-evts) [(potential-commits new-commit-response-evts)
(separate (separate
committers committers
(service-committer peeker-evt data))]) (service-committer data peeker-evt))])
(set! peekers not-ready-peekers) (set! peekers not-ready-peekers)
(set! committers potential-commits) (set! committers potential-commits)
(set! response-evts (append response-evts (set! response-evts (append response-evts
@ -1225,11 +1228,13 @@ WARNING: printf is rebound in the body of the unit to always
(handle-evt (handle-evt
read-chan read-chan
(lambda (ent) (lambda (ent)
(printf "read-chan ~s\n" ent)
(set! data (enqueue ent data)) (set! data (enqueue ent data))
(loop))) (loop)))
(handle-evt (handle-evt
clear-input-chan clear-input-chan
(lambda (_) (lambda (_)
(printf "clear-input-chan\n")
(semaphore-post peeker-sema) (semaphore-post peeker-sema)
(set! peeker-sema (make-semaphore 0)) (set! peeker-sema (make-semaphore 0))
(set! peeker-evt (semaphore-peek-evt peeker-sema)) (set! peeker-evt (semaphore-peek-evt peeker-sema))
@ -1237,6 +1242,7 @@ WARNING: printf is rebound in the body of the unit to always
(handle-evt (handle-evt
progress-event-chan progress-event-chan
(lambda (return-pr) (lambda (return-pr)
(printf "progress-event ~s\n" return-pr)
(let ([return-chan (car return-pr)] (let ([return-chan (car return-pr)]
[return-nack (cdr return-pr)]) [return-nack (cdr return-pr)])
(set! response-evts (set! response-evts
@ -1248,11 +1254,14 @@ WARNING: printf is rebound in the body of the unit to always
(handle-evt (handle-evt
peek-chan peek-chan
(lambda (peeker) (lambda (peeker)
(print-struct #t)
(printf "peek-chan ~s\n" peeker)
(set! peekers (cons peeker peekers)) (set! peekers (cons peeker peekers))
(loop))) (loop)))
(handle-evt (handle-evt
commit-chan commit-chan
(lambda (committer) (lambda (committer)
(printf "commit-chan ~s\n" committer)
(set! committers (cons committer committers)) (set! committers (cons committer committers))
(loop))) (loop)))
(apply (apply
@ -1270,12 +1279,14 @@ WARNING: printf is rebound in the body of the unit to always
(handle-evt (handle-evt
commit-peeker-evt commit-peeker-evt
(lambda (_) (lambda (_)
(printf "commit-peeker-evt\n")
;; this committer will be thrown out in next iteration ;; this committer will be thrown out in next iteration
(loop))) (loop)))
(handle-evt (handle-evt
done-evt done-evt
(lambda (v) (lambda (v)
(set! data (dequeue-n kr data)) (set! data (dequeue-n data kr))
(printf "done-evt ~s new data ~s\n" v (queue->list data))
(semaphore-post peeker-sema) (semaphore-post peeker-sema)
(set! peeker-sema (make-semaphore 0)) (set! peeker-sema (make-semaphore 0))
(set! peeker-evt (semaphore-peek-evt peeker-sema)) (set! peeker-evt (semaphore-peek-evt peeker-sema))
@ -1293,6 +1304,7 @@ WARNING: printf is rebound in the body of the unit to always
(handle-evt (handle-evt
resp-evt resp-evt
(lambda (_) (lambda (_)
(printf "resp-evt\n")
(set! response-evts (remq resp-evt response-evts)) (set! response-evts (remq resp-evt response-evts))
(loop)))) (loop))))
response-evts))))) response-evts)))))
@ -1344,22 +1356,29 @@ WARNING: printf is rebound in the body of the unit to always
(match a-peeker (match a-peeker
[($ peeker bytes skip-count pe resp-chan nack-evt) [($ peeker bytes skip-count pe resp-chan nack-evt)
(cond (cond
[(not (eq? pe peeker-evt)) [(and pe (not (eq? pe peeker-evt)))
(printf "peeker case 1 ~s ~s\n" pe peeker-evt)
(choice-evt (channel-put-evt resp-chan #f) (choice-evt (channel-put-evt resp-chan #f)
nack-evt)] nack-evt)]
[((queue-size data) . > . skip-count) [((queue-size data) . > . skip-count)
(let ([nth (peek-n data (+ skip-count 1))]) (let ([nth (peek-n data skip-count)])
(printf "peeker case 2 ~s\n" nth)
(choice-evt (choice-evt
nack-evt nack-evt
(if (byte? nth) (cond
(begin [(byte? nth)
(bytes-set! bytes 0 nth) (bytes-set! bytes 0 nth)
(channel-put-evt resp-chan 1)) (channel-put-evt resp-chan 1)]
(channel-put-evt [(eof-object? nth)
resp-chan (channel-put-evt resp-chan nth)]
(lambda (src line col pos) [else
nth)))))] (channel-put-evt
[else #f])])) resp-chan
(lambda (src line col pos)
nth))])))]
[else
(printf "peeker case 3\n")
#f])]))
(loop)))) (loop))))
@ -1371,39 +1390,48 @@ WARNING: printf is rebound in the body of the unit to always
;; in any thread (even concurrently) ;; in any thread (even concurrently)
;; ;;
(define (read-bytes-proc bstr) (define (read-bytes-proc bstr)
(printf "(read-bytes-proc ~s)\n" bstr)
(let* ([progress-evt (progress-evt-proc)] (let* ([progress-evt (progress-evt-proc)]
[v (peek-proc bstr 0 progress-evt)]) [v (peek-proc bstr 0 progress-evt)])
(cond (cond
[(sync/timeout 0 progress-evt) 0] ; try again [(sync/timeout 0 progress-evt) 0]
[(evt? v) (wrap-evt v (lambda (x) 0))] ; sync, then try again [else (wrap-evt
[(and (number? v) (zero? v)) 0] ; try again v
[else (lambda (v)
(if (commit-proc (if (number? v) v 1) (if (and (number? v) (zero? v))
progress-evt 0
always-evt) (if (commit-proc (if (number? v) v 1)
v ; got a result progress-evt
0)]))) ; try again always-evt)
v
(define (peek-proc bstr skip-count progress-evt) 0))))])))
(nack-guard-evt
(lambda (nack) (define (peek-proc bstr skip-count progress-evt)
(let ([chan (make-channel)]) (let ([ans (nack-guard-evt
(channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack)) (lambda (nack)
chan)))) (let ([chan (make-channel)])
(channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack))
chan)))])
(printf "~s -> ~s\n" (list 'peek-proc bstr skip-count progress-evt) ans)
ans))
(define (progress-evt-proc) (define (progress-evt-proc)
(nack-guard-evt (let ([ans (sync
(lambda (nack) (nack-guard-evt
(let ([chan (make-channel)]) (lambda (nack)
(channel-put progress-event-chan (cons chan nack)) (let ([chan (make-channel)])
chan)))) (channel-put progress-event-chan (cons chan nack))
chan))))])
(printf "~s -> ~s\n" (list 'progress-evt-proc) ans)
ans))
(define (commit-proc kr progress-evt done-evt) (define (commit-proc kr progress-evt done-evt)
(printf "~s\n" (list 'commit-proc kr progress-evt done-evt))
(sync (sync
(nack-guard-evt (nack-guard-evt
(lambda (nack) (lambda (nack)
(let ([chan (make-channel)]) (let ([chan (make-channel)])
(channel-put commit-chan (list kr progress-evt done-evt chan nack)) (channel-put commit-chan (make-committer kr progress-evt done-evt chan nack))
chan))))) chan)))))
(define (close-proc) (void)) (define (close-proc) (void))
@ -1438,21 +1466,24 @@ WARNING: printf is rebound in the body of the unit to always
;; dequeue-n : queue number -> queue ;; dequeue-n : queue number -> queue
(define (dequeue-n queue n) (define (dequeue-n queue n)
(printf "~s\n" (list 'dequeue-n (queue->list queue) n))
(let loop ([q queue] (let loop ([q queue]
[n n]) [n n])
(cond (cond
[(zero? n) queue] [(zero? n) q]
[(queue-empty? q) (error 'dequeue-n "not enough!")] [(queue-empty? q) (error 'dequeue-n "not enough!")]
[else (loop (queue-rest q) (- n 1))]))) [else (loop (queue-rest q) (- n 1))])))
;; peek-n : queue number -> queue ;; peek-n : queue number -> queue
(define (peek-n queue n) (define (peek-n queue init-n)
(let loop ([q queue] (let loop ([q queue]
[n n]) [n init-n])
(cond (cond
[(zero? n) [(zero? n)
(when (queue-empty? q) (when (queue-empty? q)
(error 'peek-n "not enough!")) (error 'peek-n "not enough; asked for ~a but only ~a available"
init-n
(queue-size queue)))
(queue-first q)] (queue-first q)]
[else [else
(when (queue-empty? q) (when (queue-empty? q)