From 7486c4c96d544fe14c39c19490d2c45062a38642 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 25 Jun 2004 13:52:08 +0000 Subject: [PATCH] . original commit: f2fd45489cf4e6ff640a3d59ed0b91674b7f2971 --- collects/framework/private/autosave.ss | 36 ++++++++++----------- collects/framework/private/text.ss | 45 ++++++++------------------ collects/framework/splash.ss | 6 ++-- 3 files changed, 34 insertions(+), 53 deletions(-) diff --git a/collects/framework/private/autosave.ss b/collects/framework/private/autosave.ss index e19cb6b5..0a62818f 100644 --- a/collects/framework/private/autosave.ss +++ b/collects/framework/private/autosave.ss @@ -63,7 +63,7 @@ 'text)))) (let ([seconds (preferences:get 'framework:autosave-delay)]) (start (* 1000 seconds) #t))) - (super-instantiate ()) + (super-new) (let ([seconds (preferences:get 'framework:autosave-delay)]) (start (* 1000 seconds) #t)))) @@ -134,11 +134,10 @@ [filtered-table (filter (lambda (x) (file-exists? (cadr x))) table)]) (unless (null? filtered-table) - (let* ([f (make-object final-frame% - (string-constant recover-autosave-files-frame-title))] - [t (instantiate text% () - (auto-wrap #t))] - [ec (instantiate editor-canvas% () + (let* ([f (new final-frame% + (label (string-constant recover-autosave-files-frame-title)))] + [t (new text% (auto-wrap #t))] + [ec (new editor-canvas% (parent (send f get-area-container)) (editor t) (line-count 2) @@ -168,13 +167,14 @@ (define final-frame% (class frame:basic% - (define/override (can-close?) #t) - (define/override (on-close) + (define/augment (can-close?) #t) + (define/augment (on-close) + (inner (void) on-close) (send (group:get-the-frame-group) remove-frame this) (semaphore-post done-semaphore)) - (super-instantiate ()))) + (super-new))) ;; add-table-line : (is-a? area-container<%>) (union #f (is-a?/c top-level-window<%>)) ;; -> (list (union #f string[filename]) string[filename-file-exists?]) @@ -184,27 +184,27 @@ (lambda (table-entry) (letrec ([orig-file (car table-entry)] [backup-file (cadr table-entry)] - [hp (instantiate horizontal-panel% () + [hp (new horizontal-panel% (parent area-container) (style '(border)) (stretchable-height #f))] - [vp (instantiate vertical-panel% () + [vp (new vertical-panel% (parent hp))] - [msg1-panel (instantiate horizontal-panel% () + [msg1-panel (new horizontal-panel% (parent vp))] - [msg1-label (instantiate message% () + [msg1-label (new message% (parent msg1-panel) (label (string-constant autosave-original-label:)))] - [msg1 (instantiate message% () + [msg1 (new message% (label (or orig-file (string-constant autosave-unknown-filename))) (stretchable-width #t) (parent msg1-panel))] - [msg2-panel (instantiate horizontal-panel% () + [msg2-panel (new horizontal-panel% (parent vp))] - [msg2-label (instantiate message% () + [msg2-label (new message% (parent msg2-panel) (label (string-constant autosave-autosave-label:)))] - [msg2 (instantiate message% () + [msg2 (new message% (label backup-file) (stretchable-width #t) (parent msg2-panel))] @@ -275,7 +275,7 @@ #f (if file1 600 300) 600)) - (define hp (instantiate horizontal-panel% () + (define hp (new horizontal-panel% (parent (send frame get-area-container)))) (when file1 (add-file-viewer file1 hp (string-constant autosave-original-label))) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 4c383c24..afdf4189 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -34,7 +34,7 @@ WARNING: printf is rebound in the body of the unit to always (define original-output-port (current-output-port)) (define (printf . args) - ;(apply fprintf original-output-port args) + (apply fprintf original-output-port args) (void)) (define-struct range (start end b/w-bitmap color caret-space?)) @@ -1186,7 +1186,6 @@ WARNING: printf is rebound in the body of the unit to always ;; loop : -> alpha ;; the main loop for this thread (define (loop) - (printf "loop ~s\n" (queue->list data)) (let-values ([(not-ready-peekers new-peek-response-evts) (separate peekers service-waiter)] [(potential-commits new-commit-response-evts) @@ -1202,13 +1201,11 @@ WARNING: printf is rebound in the body of the unit to always (handle-evt read-chan (lambda (ent) - (printf "read-chan ~s\n" ent) (set! data (enqueue ent data)) (loop))) (handle-evt clear-input-chan (lambda (_) - (printf "clear-input-chan\n") (semaphore-post peeker-sema) (set! peeker-sema (make-semaphore 0)) (set! peeker-evt (semaphore-peek-evt peeker-sema)) @@ -1217,7 +1214,6 @@ WARNING: printf is rebound in the body of the unit to always (handle-evt progress-event-chan (lambda (return-pr) - (printf "progress-event ~s\n" return-pr) (let ([return-chan (car return-pr)] [return-nack (cdr return-pr)]) (set! response-evts @@ -1230,13 +1226,11 @@ WARNING: printf is rebound in the body of the unit to always peek-chan (lambda (peeker) (print-struct #t) - (printf "peek-chan ~s\n" peeker) (set! peekers (cons peeker peekers)) (loop))) (handle-evt commit-chan (lambda (committer) - (printf "commit-chan ~s\n" committer) (set! committers (cons committer committers)) (loop))) (apply @@ -1253,15 +1247,13 @@ WARNING: printf is rebound in the body of the unit to always (choice-evt (handle-evt commit-peeker-evt - (lambda (_) - (printf "commit-peeker-evt\n") + (lambda (_) ;; this committer will be thrown out in next iteration (loop))) (handle-evt done-evt (lambda (v) (set! data (dequeue-n data kr)) - (printf "done-evt ~s new data ~s\n" v (queue->list data)) (semaphore-post peeker-sema) (set! peeker-sema (make-semaphore 0)) (set! peeker-evt (semaphore-peek-evt peeker-sema)) @@ -1279,7 +1271,6 @@ WARNING: printf is rebound in the body of the unit to always (handle-evt resp-evt (lambda (_) - (printf "resp-evt\n") (set! response-evts (remq resp-evt response-evts)) (loop)))) response-evts))))) @@ -1332,12 +1323,10 @@ WARNING: printf is rebound in the body of the unit to always [($ peeker bytes skip-count pe resp-chan nack-evt) (cond [(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) nack-evt)] [((queue-size data) . > . skip-count) (let ([nth (peek-n data skip-count)]) - (printf "peeker case 2 ~s\n" nth) (choice-evt nack-evt (cond @@ -1352,7 +1341,6 @@ WARNING: printf is rebound in the body of the unit to always (lambda (src line col pos) nth))])))] [else - (printf "peeker case 3\n") #f])])) (loop)))) @@ -1365,7 +1353,6 @@ WARNING: printf is rebound in the body of the unit to always ;; in any thread (even concurrently) ;; (define (read-bytes-proc bstr) - (printf "(read-bytes-proc ~s)\n" bstr) (let* ([progress-evt (progress-evt-proc)] [v (peek-proc bstr 0 progress-evt)]) (cond @@ -1382,26 +1369,21 @@ WARNING: printf is rebound in the body of the unit to always 0))))]))) (define (peek-proc bstr skip-count progress-evt) - (let ([ans (nack-guard-evt - (lambda (nack) - (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)) + (nack-guard-evt + (lambda (nack) + (let ([chan (make-channel)]) + (channel-put peek-chan (make-peeker bstr skip-count progress-evt chan nack)) + chan)))) (define (progress-evt-proc) - (let ([ans (sync - (nack-guard-evt - (lambda (nack) - (let ([chan (make-channel)]) - (channel-put progress-event-chan (cons chan nack)) - chan))))]) - (printf "~s -> ~s\n" (list 'progress-evt-proc) ans) - ans)) + (sync + (nack-guard-evt + (lambda (nack) + (let ([chan (make-channel)]) + (channel-put progress-event-chan (cons chan nack)) + chan))))) (define (commit-proc kr progress-evt done-evt) - (printf "~s\n" (list 'commit-proc kr progress-evt done-evt)) (sync (nack-guard-evt (lambda (nack) @@ -1441,7 +1423,6 @@ WARNING: printf is rebound in the body of the unit to always ;; dequeue-n : queue number -> queue (define (dequeue-n queue n) - (printf "~s\n" (list 'dequeue-n (queue->list queue) n)) (let loop ([q queue] [n n]) (cond diff --git a/collects/framework/splash.ss b/collects/framework/splash.ss index 367d7c31..6e86dd92 100644 --- a/collects/framework/splash.ss +++ b/collects/framework/splash.ss @@ -110,7 +110,7 @@ (splash-load-handler old-load f expected)))) ;; abstraction breaking -- matthew will change cm - ;; so that I don't need this here. + ;; so that I don't need this here(?). (when addl-load-handler (printf "PLTDRCM: reinstalling CM load handler after setting splash load handler\n") (current-load/use-compiled (addl-load-handler)))) @@ -187,10 +187,10 @@ (define splash-frame% (class frame% - (define/override (on-close) + (define/augment (on-close) (when quit-on-close? (exit))) - (super-instantiate ()))) + (super-new))) (define splash-canvas% (class canvas%