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

.

Browse Source 
original commit: d56107d7a4fc2ed1b101af2435b36e3e869bb1f7
This commit is contained in:
Robby Findler 2004-08-12 19:05:24 +00:00
parent 3fa1b48029
commit 3fa2b72e5e
2 changed files with 28 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/framework/private/frame.ss
View File

@ -217,12 +217,11 @@
(let ([number-of-frames (let ([number-of-frames
(length (send (group:get-the-frame-group) (length (send (group:get-the-frame-group)
get-frames))]) get-frames))])
(if (preferences:get 'framework:exit-when-no-frames) (and (inner #t can-close?)
(and (inner #t can-close?) (or (preferences:get 'framework:exit-when-no-frames)
(or (exit:exiting?) (exit:exiting?)
(not (= 1 number-of-frames)) (not (= 1 number-of-frames))
(exit:user-oks-exit))) (exit:user-oks-exit)))))
#t)))
(define/augment (on-close) (define/augment (on-close)
(send (group:get-the-frame-group) (send (group:get-the-frame-group)
remove-frame remove-frame

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

@ -40,7 +40,7 @@ WARNING: printf is rebound in the body of the unit to always
(syntax-case stx () (syntax-case stx ()
[(_ . args) [(_ . args)
#;(syntax (printf . args)) #;(syntax (printf . args))
(syntax (void))])) (syntax (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))
@ -1040,7 +1040,7 @@ WARNING: printf is rebound in the body of the unit to always
(let ([inserted-count (let ([inserted-count
(if (is-a? str/snp snip%) (if (is-a? str/snp snip%)
1 (send str/snp get-count)
(string-length str/snp))] (string-length str/snp))]
[old-insertion-point insertion-point]) [old-insertion-point insertion-point])
(set! insertion-point (+ insertion-point inserted-count)) (set! insertion-point (+ insertion-point inserted-count))
@ -1052,7 +1052,12 @@ WARNING: printf is rebound in the body of the unit to always
old-insertion-point old-insertion-point
old-insertion-point old-insertion-point
#f) #f)
(change-style sd old-insertion-point insertion-point)))
;; the idea here is that if you made a string snip, you
;; could have made a string and gotten the style, so you
;; must intend to have your own style....
(unless (is-a? str/snp string-snip%)
(change-style sd old-insertion-point insertion-point))))
(loop (cdr txts))])) (loop (cdr txts))]))
(set! allow-edits? #f) (set! allow-edits? #f)
(lock locked?) (lock locked?)
@ -1072,22 +1077,28 @@ WARNING: printf is rebound in the body of the unit to always
(handle-evt (handle-evt
(alarm-evt (+ last-flush msec-timeout)) (alarm-evt (+ last-flush msec-timeout))
(lambda (_) (lambda (_)
(dprintf "o: alarm.1 ~s\n" (queue->list text-to-insert))
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)]) (let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
(dprintf "o: alarm.2 ~s\n" viable-bytes)
(queue-insertion viable-bytes always-evt) (queue-insertion viable-bytes always-evt)
(loop remaining-queue (current-inexact-milliseconds)))))) (loop remaining-queue (current-inexact-milliseconds))))))
(handle-evt (handle-evt
flush-chan flush-chan
(lambda (return-evt) (lambda (return-evt)
(dprintf "o: flush.1 ~s\n" (queue->list text-to-insert))
(let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)]) (let-values ([(viable-bytes remaining-queue) (split-queue converter text-to-insert)])
(dprintf "o: flush.2 ~s\n" viable-bytes)
(queue-insertion viable-bytes return-evt) (queue-insertion viable-bytes return-evt)
(loop remaining-queue (current-inexact-milliseconds))))) (loop remaining-queue (current-inexact-milliseconds)))))
(handle-evt (handle-evt
clear-output-chan clear-output-chan
(lambda (_) (lambda (_)
(dprintf "o: clear-output\n")
(loop (empty-queue) (current-inexact-milliseconds)))) (loop (empty-queue) (current-inexact-milliseconds))))
(handle-evt (handle-evt
write-chan write-chan
(lambda (pr) (lambda (pr)
(dprintf "o: write ~s\n" pr)
(let ([new-text-to-insert (enqueue pr text-to-insert)]) (let ([new-text-to-insert (enqueue pr text-to-insert)])
(cond (cond
[((queue-size text-to-insert) . < . output-buffer-full) [((queue-size text-to-insert) . < . output-buffer-full)
@ -1236,7 +1247,7 @@ WARNING: printf is rebound in the body of the unit to always
(handle-evt (handle-evt
position-chan position-chan
(lambda (pr) (lambda (pr)
(dprintf "position-chan\n") (dprintf "i: position-chan\n")
(let ([nack-chan (car pr)] (let ([nack-chan (car pr)]
[resp-chan (cdr pr)]) [resp-chan (cdr pr)])
(set! positioners (cons pr positioners)) (set! positioners (cons pr positioners))
@ -1247,7 +1258,7 @@ WARNING: printf is rebound in the body of the unit to always
(handle-evt (handle-evt
read-chan read-chan
(lambda (ent) (lambda (ent)
(dprintf "read-chan\n") (dprintf "i: read-chan\n")
(set! data (enqueue ent data)) (set! data (enqueue ent data))
(unless position (unless position
(set! position (cdr ent))) (set! position (cdr ent)))
@ -1255,7 +1266,7 @@ WARNING: printf is rebound in the body of the unit to always
(handle-evt (handle-evt
clear-input-chan clear-input-chan
(lambda (_) (lambda (_)
(dprintf "clear-input-chan\n") (dprintf "i: 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))
@ -1265,7 +1276,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)
(dprintf "progress-event-chan\n") (dprintf "i: progress-event-chan\n")
(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
@ -1277,13 +1288,13 @@ WARNING: printf is rebound in the body of the unit to always
(handle-evt (handle-evt
peek-chan peek-chan
(lambda (peeker) (lambda (peeker)
(dprintf "peek-chan\n") (dprintf "i: peek-chan\n")
(set! peekers (cons peeker peekers)) (set! peekers (cons peeker peekers))
(loop))) (loop)))
(handle-evt (handle-evt
commit-chan commit-chan
(lambda (committer) (lambda (committer)
(dprintf "commit-chan\n") (dprintf "i:commit-chan\n")
(set! committers (cons committer committers)) (set! committers (cons committer committers))
(loop))) (loop)))
(apply (apply
@ -1301,13 +1312,13 @@ WARNING: printf is rebound in the body of the unit to always
(handle-evt (handle-evt
commit-peeker-evt commit-peeker-evt
(lambda (_) (lambda (_)
(dprintf "commit-peeker-evt\n") (dprintf "i: 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)
(dprintf "done-evt\n") (dprintf "i: done-evt\n")
(let ([nth-pos (cdr (peek-n data (- kr 1)))]) (let ([nth-pos (cdr (peek-n data (- kr 1)))])
(set! position (set! position
(list (car nth-pos) (list (car nth-pos)
@ -1331,14 +1342,13 @@ WARNING: printf is rebound in the body of the unit to always
(handle-evt (handle-evt
resp-evt resp-evt
(lambda (_) (lambda (_)
(dprintf "resp-evt\n") (dprintf "i: 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)))))
;; service-positioner : (cons (channel void) (channel line-col-pos)) -> evt ;; service-positioner : (cons (channel void) (channel line-col-pos)) -> evt
(define (service-positioner pr) (define (service-positioner pr)
(dprintf "service-position ~s\n" pr)
(let ([nack-evt (car pr)] (let ([nack-evt (car pr)]
[resp-evt (cdr pr)]) [resp-evt (cdr pr)])
(handle-evt (handle-evt
@ -1405,7 +1415,6 @@ WARNING: printf is rebound in the body of the unit to always
(let loop ([eles eles] (let loop ([eles eles]
[transformed '()] [transformed '()]
[left-alone '()]) [left-alone '()])
(dprintf "separate\n")
(cond (cond
[(null? eles) (values left-alone transformed)] [(null? eles) (values left-alone transformed)]
[else (let* ([ele (car eles)] [else (let* ([ele (car eles)]