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

.

Browse Source 
original commit: 17eb27d406163b36c41644d008be15484ed39faa
This commit is contained in:
Robby Findler 2004-10-19 14:14:04 +00:00
parent a0e81f7b3c
commit 9f47be3d48
1 changed files with 34 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -878,6 +878,9 @@ WARNING: printf is rebound in the body of the unit to always
send-eof-to-in-port send-eof-to-in-port
clear-output-ports clear-output-ports
clear-input-port clear-input-port
get-out-style-delta
get-err-style-delta
get-value-style-delta
get-in-port get-in-port
get-out-port get-out-port
get-err-port get-err-port
@ -987,6 +990,18 @@ WARNING: printf is rebound in the body of the unit to always
(define/pubment (submit-to-port? key) (inner #t submit-to-port? key)) (define/pubment (submit-to-port? key) (inner #t submit-to-port? key))
(define/pubment (on-submit) (inner (void) on-submit)) (define/pubment (on-submit) (inner (void) on-submit))
(define/public (get-out-style-delta)
(let ([out-sd (make-object style-delta% 'change-normal)])
(send out-sd set-delta-foreground (make-object color% 150 0 150))
out-sd))
(define/public (get-err-style-delta)
(let ([err-sd (make-object style-delta% 'change-italic)])
(send err-sd set-delta-foreground (make-object color% 255 0 0))
err-sd))
(define/public (get-value-style-delta)
(let ([value-sd (make-object style-delta% 'change-family 'modern)])
(send value-sd set-delta-foreground (make-object color% 0 0 175))
value-sd))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
@ -1214,13 +1229,9 @@ WARNING: printf is rebound in the body of the unit to always
(channel-put write-chan (cons special style))]) (channel-put write-chan (cons special style))])
#t)) #t))
(define out-sd (make-object style-delta% 'change-normal)) (let ([out-sd (get-out-style-delta)]
(define err-sd (make-object style-delta% 'change-italic)) [err-sd (get-err-style-delta)]
(define value-sd (make-object style-delta% 'change-family 'modern)) [value-sd (get-value-style-delta)])
(send out-sd set-delta-foreground (make-object color% 150 0 150))
(send err-sd set-delta-foreground (make-object color% 255 0 0))
(send value-sd set-delta-foreground (make-object color% 0 0 175))
(set! out-port (make-output-port #f (set! out-port (make-output-port #f
always-evt always-evt
(make-write-bytes-proc out-sd) (make-write-bytes-proc out-sd)
@ -1235,7 +1246,7 @@ WARNING: printf is rebound in the body of the unit to always
always-evt always-evt
(make-write-bytes-proc value-sd) (make-write-bytes-proc value-sd)
out-close-proc out-close-proc
(make-write-special-proc value-sd)))) (make-write-special-proc value-sd)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
@ -1684,10 +1695,9 @@ WARNING: printf is rebound in the body of the unit to always
[else (if acc [else (if acc
(values (cons acc key) lst) (values (cons acc key) lst)
(values fst (cdr lst)))]))]))) (values fst (cdr lst)))]))])))
(super-new)
(init-input-port) (init-input-port)
(init-output-ports) (init-output-ports)))
(super-new)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;