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

.

Browse Source 
original commit: 41b2d831b9f4764d759b1630ab2c6d7dfcdb58bd
This commit is contained in:
Robby Findler 2004-04-29 22:54:11 +00:00
parent c7faaba768
commit 3d45da9d12
2 changed files with 30 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/framework/framework.ss
View File

@ -151,7 +151,7 @@
"\\var{symbol} to \\var{value}. This should be called when the" "\\var{symbol} to \\var{value}. This should be called when the"
"users requests a change to a preference.") "users requests a change to a preference.")
(preferences:set-default (preferences:set-default
(symbol? any? (any? . -> . any?) . -> . void?) (symbol? any? (any? . -> . any) . -> . void?)
(symbol value test) (symbol value test)
"This function must be called every time your application starts up, before any call to" "This function must be called every time your application starts up, before any call to"
"@flink preferences:get %" "@flink preferences:get %"

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

@ -1024,8 +1024,7 @@ WARNING: printf is rebound in the body of the unit to always
(define read-chan (make-channel)) (define read-chan (make-channel))
;; readers-chan : (channel (list (channel (union byte snip)) ;; readers-chan : (channel (list (channel (union byte snip))
;; (channel ...) ;; (channel ...)))
;; (union #f number)))
(define readers-chan (make-channel)) (define readers-chan (make-channel))
;; readers-waiting-chan : (channel (channel boolean)) ;; readers-waiting-chan : (channel (channel boolean))
@ -1124,38 +1123,31 @@ WARNING: printf is rebound in the body of the unit to always
[(queue-empty? data) (readers-waiting readers)] [(queue-empty? data) (readers-waiting readers)]
[(queue-empty? readers) (data-waiting data)] [(queue-empty? readers) (data-waiting data)]
[else [else
(let-values ([(reader datum new-readers new-data) (let* ([data-hd (queue-first data)]
(find-matching-reader/datum readers data)]) [reader-hd (queue-first readers)]
(let* ([reader-succeed (car reader-hd)] [reader-succeed (car reader-hd)]
[reader-fail (cadr reader-hd)]) [reader-fail (cdr reader-hd)])
(object-wait-multiple (object-wait-multiple
#f #f
(make-wrapped-waitable (make-wrapped-waitable
clear-input-chan clear-input-chan
(lambda (_) (lambda (_)
(data-and-readers-waiting (empty-queue) (empty-queue)))) (data-and-readers-waiting (empty-queue) (empty-queue))))
(make-wrapped-waitable (make-wrapped-waitable
readers-waiting-chan readers-waiting-chan
(lambda (result) (lambda (result)
(channel-put result #t) (channel-put result #t)
(data-and-readers-waiting data readers))) (data-and-readers-waiting data readers)))
(make-wrapped-waitable (make-wrapped-waitable
(make-channel-put-waitable reader-succeed data-hd) (make-channel-put-waitable reader-succeed data-hd)
(lambda (v) (lambda (v)
(data-and-readers-waiting (data-and-readers-waiting (queue-rest data)
new-readers (queue-rest readers))))
new-data))) (make-wrapped-waitable
(make-wrapped-waitable reader-fail
reader-fail (lambda (v)
(lambda (v) (data-and-readers-waiting data
(data-and-readers-waiting data (queue-rest readers))))))]))
(queue-rest readers)))))))]))
(define (find-matching-reader/datum readers data)
(let ([data-size (queue-size data)])
(let loop ([readers readers])
(cond
[(null? readers)
(data-and-readers-waiting (empty-queue) (empty-queue))))) (data-and-readers-waiting (empty-queue) (empty-queue)))))
@ -1203,10 +1195,7 @@ WARNING: printf is rebound in the body of the unit to always
;; in any thread (even concurrently) ;; in any thread (even concurrently)
;; ;;
(define op (current-output-port)) (define op (current-output-port))
(define (peek-bytes-proc bytes to-skip) (do-peek/read bytes to-skip)) (define (read-bytes-proc bytes)
(define (read-bytes-proc bytes) (do-peek/read bytes #f))
(define (do-peek/read bytes peek/count)
;; this shouldn't return 0. it should return a waitable and ;; this shouldn't return 0. it should return a waitable and
;; let the system block and then re-call into this thing. ;; let the system block and then re-call into this thing.
;; yuck. ;; yuck.
@ -1219,7 +1208,7 @@ WARNING: printf is rebound in the body of the unit to always
(make-nack-guard-waitable (make-nack-guard-waitable
(lambda (fail-channel) (lambda (fail-channel)
(let ([return-channel (make-channel)]) (let ([return-channel (make-channel)])
(channel-put readers-chan (list return-channel fail-channel peek/count)) (channel-put readers-chan (list return-channel fail-channel))
return-channel))))]) return-channel))))])
(cond (cond
[(byte? s/c) [(byte? s/c)
@ -1270,7 +1259,7 @@ WARNING: printf is rebound in the body of the unit to always
(send value-sd set-delta-foreground (make-object color% 0 0 175)) (send value-sd set-delta-foreground (make-object color% 0 0 175))
(set! in-port (make-custom-input-port read-bytes-proc (set! in-port (make-custom-input-port read-bytes-proc
peek-bytes-proc #f
in-close-proc)) in-close-proc))
(set! out-port (make-custom-output-port #f (set! out-port (make-custom-output-port #f
(make-write-bytes-proc out-sd) (make-write-bytes-proc out-sd)