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

.

Browse Source 
original commit: 8a4ca26055a0cf996312b730c384e6819e966429
This commit is contained in:
Robby Findler 2004-04-29 12:57:15 +00:00
parent 1294ceaec3
commit c7faaba768
3 changed files with 66 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/framework/private/main.ss
View File

@ -22,6 +22,10 @@
(application-preferences-handler (lambda () (preferences:show-dialog))) (application-preferences-handler (lambda () (preferences:show-dialog)))
(preferences:set-default 'framework:special-option-key #f boolean?)
(preferences:add-callback 'framework:special-option-key (lambda (p v) (special-option-key v)))
(special-option-key (preferences:get 'framework:special-option-key))
(preferences:set-default 'framework:fraction-snip-style 'mixed (lambda (x) (memq x '(mixed improper)))) (preferences:set-default 'framework:fraction-snip-style 'mixed (lambda (x) (memq x '(mixed improper))))
(preferences:set-default 'framework:standard-style-list:font-name (preferences:set-default 'framework:standard-style-list:font-name

5
collects/framework/private/preferences.ss
View File

@ -776,6 +776,11 @@
'framework:coloring-active 'framework:coloring-active
(string-constant online-coloring-active) (string-constant online-coloring-active)
values values) values values)
(when (memq (system-type) '(macos macosx))
(make-check editor-panel
'framework:special-option-key
(string-constant option-as-meta)
values values))
(unless (eq? (system-type) 'unix) (unless (eq? (system-type) 'unix)
(make-check editor-panel (make-check editor-panel
'framework:print-output-mode 'framework:print-output-mode

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

@ -848,7 +848,8 @@ WARNING: printf is rebound in the body of the unit to always
submit-to-port? submit-to-port?
on-submit on-submit
send-eof-to-in-port send-eof-to-in-port
clear-ports clear-output-ports
clear-input-port
get-in-port get-in-port
get-out-port get-out-port
get-err-port get-err-port
@ -917,10 +918,12 @@ WARNING: printf is rebound in the body of the unit to always
(define/public (send-eof-to-in-port) (channel-put read-chan eof)) (define/public (send-eof-to-in-port) (channel-put read-chan eof))
(define/public (clear-ports) (define/public (clear-input-port)
(channel-put clear-output-chan (void))
(channel-put clear-input-chan (void))) (channel-put clear-input-chan (void)))
(define/public (clear-output-ports)
(channel-put clear-output-chan (void)))
(define/public (get-in-port) (define/public (get-in-port)
(unless in-port (error 'get-in-port "not ready")) (unless in-port (error 'get-in-port "not ready"))
in-port) in-port)
@ -934,7 +937,6 @@ WARNING: printf is rebound in the body of the unit to always
(unless err-port (error 'get-value-port "not ready")) (unless err-port (error 'get-value-port "not ready"))
value-port) value-port)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; specialization interface ;; specialization interface
@ -1021,12 +1023,13 @@ WARNING: printf is rebound in the body of the unit to always
;; send input from the editor ;; send input from the editor
(define read-chan (make-channel)) (define read-chan (make-channel))
;; readers-chan : (channel (cons (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))
;; peek-chan : (channel (channel boolean)) ;; readers-waiting-chan : (channel (channel boolean))
(define peek-chan (make-channel)) (define readers-waiting-chan (make-channel))
;; queue-insertion : (listof (cons (union string snip) style-delta)) waitable -> void ;; queue-insertion : (listof (cons (union string snip) style-delta)) waitable -> void
;; txt is in the reverse order of the things to be inserted. ;; txt is in the reverse order of the things to be inserted.
@ -1073,10 +1076,11 @@ WARNING: printf is rebound in the body of the unit to always
(thread (thread
(lambda () (lambda ()
(define (data-waiting data) (define (data-waiting data)
(printf "data-waiting ~s\n" (queue->list data))
(object-wait-multiple (object-wait-multiple
#f #f
(make-wrapped-waitable (make-wrapped-waitable
peek-chan readers-waiting-chan
(lambda (result) (lambda (result)
(channel-put result #t) (channel-put result #t)
(data-waiting data))) (data-waiting data)))
@ -1094,6 +1098,7 @@ WARNING: printf is rebound in the body of the unit to always
(data-and-readers-waiting data (enqueue new-reader (empty-queue))))))) (data-and-readers-waiting data (enqueue new-reader (empty-queue)))))))
(define (readers-waiting readers) (define (readers-waiting readers)
(printf "readers-waiting ~s\n" (queue->list readers))
(object-wait-multiple (object-wait-multiple
#f #f
(make-wrapped-waitable (make-wrapped-waitable
@ -1101,7 +1106,7 @@ WARNING: printf is rebound in the body of the unit to always
(lambda (_) (lambda (_)
(data-and-readers-waiting (empty-queue) (empty-queue)))) (data-and-readers-waiting (empty-queue) (empty-queue))))
(make-wrapped-waitable (make-wrapped-waitable
peek-chan readers-waiting-chan
(lambda (result) (lambda (result)
(channel-put result #f) (channel-put result #f)
(readers-waiting readers))) (readers-waiting readers)))
@ -1118,10 +1123,11 @@ WARNING: printf is rebound in the body of the unit to always
(cond (cond
[(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 (let* ([data-hd (queue-first data)] [else
[reader-hd (queue-first readers)] (let-values ([(reader datum new-readers new-data)
[reader-succeed (car reader-hd)] (find-matching-reader/datum readers data)])
[reader-fail (cdr reader-hd)]) (let* ([reader-succeed (car reader-hd)]
[reader-fail (cadr reader-hd)])
(object-wait-multiple (object-wait-multiple
#f #f
(make-wrapped-waitable (make-wrapped-waitable
@ -1129,20 +1135,28 @@ WARNING: printf is rebound in the body of the unit to always
(lambda (_) (lambda (_)
(data-and-readers-waiting (empty-queue) (empty-queue)))) (data-and-readers-waiting (empty-queue) (empty-queue))))
(make-wrapped-waitable (make-wrapped-waitable
peek-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 (queue-rest data) (data-and-readers-waiting
(queue-rest readers)))) new-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)))))
(define output-buffer-thread (define output-buffer-thread
@ -1189,31 +1203,33 @@ 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 (read-bytes-proc bytes) (define (peek-bytes-proc bytes to-skip) (do-peek/read bytes to-skip))
(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.
(let ([any-waiting-chan (make-channel)]) (let ([readers-waiting-answer-chan (make-channel)])
(channel-put peek-chan any-waiting-chan) (channel-put readers-waiting-chan readers-waiting-answer-chan)
(let ([data-waiting? (channel-get any-waiting-chan)]) (if (channel-get readers-waiting-answer-chan)
(if data-waiting? (let ([s/c
(let ([s/c (object-wait-multiple
(object-wait-multiple #f
#f (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 (cons return-channel fail-channel)) return-channel))))])
return-channel))))]) (cond
(cond [(byte? s/c)
[(byte? s/c) (bytes-set! bytes 0 s/c)
(bytes-set! bytes 0 s/c) 1]
1] [(eof-object? s/c) s/c]
[(eof-object? s/c) s/c] [else
[else (lambda (src line column position)
(lambda (src line column position) (values s/c 1))]))
(values s/c 1))])) 0)))
0))))
(define (in-close-proc) (void)) (define (in-close-proc) (void))
@ -1254,7 +1270,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
#f peek-bytes-proc
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)