From abfbc1dfc43e20a81265357da192fdc208a32c16 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 5 Jan 1999 04:28:26 +0000 Subject: [PATCH] ... original commit: a17f24f190476e573d325c7bf7dd58159eb20e70 --- collects/framework/editor.ss | 21 ++++++++++- collects/framework/frame.ss | 24 ++++++------ collects/framework/frameworks.ss | 3 -- collects/framework/icon.ss | 50 ++++++++++--------------- collects/framework/scheme.ss | 40 +++++++++++--------- collects/framework/splash.ss | 64 +++++++++++++++++++------------- collects/framework/text.ss | 12 +++--- 7 files changed, 120 insertions(+), 94 deletions(-) diff --git a/collects/framework/editor.ss b/collects/framework/editor.ss index da21588c..67aee3aa 100644 --- a/collects/framework/editor.ss +++ b/collects/framework/editor.ss @@ -27,6 +27,25 @@ refresh-delayed? get-canvas get-max-width get-admin set-filename) + + (rename [super-begin-edit-sequence begin-edit-sequence] + [super-end-edit-sequence end-edit-sequence]) + (private + [edit-sequence-count 0]) + (override + [begin-edit-sequence + (lambda () + (set! edit-sequence-count (+ edit-sequence-count 1)) + (super-begin-edit-sequence))] + [end-edit-sequence + (lambda () + (set! edit-sequence-count (- edit-sequence-count 1)) + (when (< edit-sequence-count 0) + (error 'end-edit-sequence "extra end-edit-sequence")) + (super-end-edit-sequence))]) + + + (rename [super-set-modified set-modified] [super-on-focus on-focus] [super-lock lock]) @@ -176,7 +195,7 @@ [check-lock (lambda () (let* ([filename (get-filename)] - [lock? (and (not (null? filename)) + [lock? (and filename (file-exists? filename) (not (member 'write diff --git a/collects/framework/frame.ss b/collects/framework/frame.ss index 710641e4..d1908421 100644 --- a/collects/framework/frame.ss +++ b/collects/framework/frame.ss @@ -141,8 +141,8 @@ (unless (implementation? % <%>) (let ([name (inferred-name this)]) (error (or name 'frame:editor%) - "result of get-editor% method must match ~e class; got: ~e" - % <%>))) + "result of get-editor% method must match ~e interface; got: ~e" + <%> %))) (make-object %)))]) @@ -451,6 +451,7 @@ [super-root 'unitiaialized-super-root]) (override [get-editor<%> (lambda () text:searching<%>)] + [get-editor% (lambda () text:searching%)] [edit-menu:find (lambda (menu evt) (search))]) (override [make-root-area-container @@ -705,7 +706,8 @@ r-root))]) (override - [get-editor<%> (lambda () text:info<%>)]) + [get-editor<%> (lambda () text:info<%>)] + [get-editor% (lambda () text:info%)]) (public [determine-width @@ -766,13 +768,11 @@ (set! icon-currently-locked? locked-now?) (let ([label (if locked-now? - (cons (icon:get-lock-bdc) - (icon:get-lock-bitmap)) - (cons (icon:get-unlock-bdc) - (icon:get-unlock-bitmap)))]) + (icon:get-lock-bitmap) + (icon:get-unlock-bitmap))]) (send lock-message set-label - (if (send (car label) ok?) + (if (send label ok?) label (if locked-now? "Locked" "Unlocked"))))))))))]) (public @@ -835,7 +835,8 @@ (border 3)) (send* time-canvas (set-editor time-edit) - (stretchable-width #f)) + (stretchable-width #f) + (stretchable-height #f)) (semaphore-wait time-semaphore) (determine-width wide-time time-canvas time-edit) (semaphore-post time-semaphore) @@ -971,7 +972,6 @@ "Overwrite" (get-info-panel))] [position-canvas (make-object editor-canvas% (get-info-panel) #f '(no-hscroll no-vscroll))] - [_2 (send position-canvas set-line-count 1)] [position-edit (make-object text%)]) (inherit determine-width) @@ -991,8 +991,10 @@ (send anchor-message show #f) (send overwrite-message show #f) (send* position-canvas + (set-line-count 1) (set-editor position-edit) - (stretchable-width #f)) + (stretchable-width #f) + (stretchable-height #f)) (determine-width "0000:000-0000:000" position-canvas position-edit) diff --git a/collects/framework/frameworks.ss b/collects/framework/frameworks.ss index 63ff9844..a36bd528 100644 --- a/collects/framework/frameworks.ss +++ b/collects/framework/frameworks.ss @@ -195,11 +195,8 @@ get-autowrap-bitmap get-lock-bitmap - get-lock-bdc get-unlock-bitmap - get-unlock-bdc get-anchor-bitmap - get-anchor-bdc get-gc-on-bitmap get-gc-off-bitmap)) diff --git a/collects/framework/icon.ss b/collects/framework/icon.ss index e9b439cb..ffa5a215 100644 --- a/collects/framework/icon.ss +++ b/collects/framework/icon.ss @@ -6,44 +6,32 @@ (collection-path "icons"))) (define (load-icon name type) - (let ([p (build-path icon-path name)] - [bitmap #f]) + (letrec ([p (build-path icon-path name)] + [f + (lambda () + (let ([bitmap (make-object bitmap% p type)]) + (set! f (lambda () bitmap)) + bitmap))]) (unless (file-exists? p) (fprintf (current-error-port) "WARNING: couldn't find ~a~n" p)) (lambda () - (if bitmap - bitmap - (begin (set! bitmap (make-object bitmap% p type)) - bitmap))))) + (f)))) - (define (load-bitmap/bdc name type) - (let* ([p (build-path icon-path name)] - [bitmap #f] - [bitmap-dc #f] - [force - (lambda () - (set! bitmap (make-object bitmap% p type)) - (set! bitmap-dc (make-object bitmap-dc%)) - (when (send bitmap ok?) - (send bitmap-dc set-bitmap bitmap)))]) + (define (load-bitmap name type) + (letrec ([p (build-path icon-path name)] + [f + (lambda () + (let ([bitmap (make-object bitmap% p type)]) + (set! f (lambda () bitmap)) + bitmap))]) (unless (file-exists? p) (fprintf (current-error-port) "WARNING: couldn't find ~a~n" p)) - (values - (lambda () - (or bitmap - (begin (force) - bitmap))) - (lambda () - (or bitmap-dc - (begin (force) - bitmap-dc)))))) + (lambda () + (f)))) - (define-values (get-anchor-bitmap get-anchor-bdc) - (load-bitmap/bdc "anchor.gif" 'gif)) - (define-values (get-lock-bitmap get-lock-bdc) - (load-bitmap/bdc "lock.gif" 'gif)) - (define-values (get-unlock-bitmap get-unlock-bdc) - (load-bitmap/bdc "unlock.gif" 'gif)) + (define-values (get-anchor-bitmap) (load-bitmap "anchor.gif" 'gif)) + (define-values (get-lock-bitmap) (load-bitmap "lock.gif" 'gif)) + (define-values (get-unlock-bitmap) (load-bitmap "unlock.gif" 'gif)) (define get-autowrap-bitmap (load-icon "return.xbm" 'xbm)) (define get-paren-highlight-bitmap (load-icon "paren.xbm" 'xbm)) diff --git a/collects/framework/scheme.ss b/collects/framework/scheme.ss index 61840987..30c5d235 100644 --- a/collects/framework/scheme.ss +++ b/collects/framework/scheme.ss @@ -111,10 +111,10 @@ (let ([line (position-line position)]) (ormap (lambda (comment-start) - (let ([f (send find-string comment-start 'backward position)]) - (if (= -1 f) - #f - (= (send position-line f) line)))) + (let ([f (find-string comment-start 'backward position)]) + (if f + (= (send position-line f) line) + #f))) (scheme-paren:get-comments))))]) (private [remove-indents-callback @@ -145,19 +145,19 @@ (override [on-focus (lambda (on?) - (super-on-focus) + (super-on-focus on?) (highlight-parens (not on?)))] [on-change-style (lambda (start len) (begin-edit-sequence) - (super-on-change-style) + (super-on-change-style start len) #t)] [after-change-style (lambda (start len) (end-edit-sequence) (unless (get-styles-fixed) (highlight-parens)) - (super-after-change-style))] + (super-after-change-style start len))] [after-edit-sequence (lambda () (unless in-highlight-parens? @@ -166,17 +166,17 @@ [on-insert (lambda (start size) (begin-edit-sequence) - (super-on-insert))] + (super-on-insert start size))] [after-insert (lambda (start size) (send backward-cache invalidate start) (send forward-cache forward-invalidate start size) (end-edit-sequence) (highlight-parens) - (super-after-insert))] + (super-after-insert start size))] [on-delete (lambda (start size) - (and (super-on-delete) + (and (super-on-delete start size) (begin (send backward-cache invalidate start) (send forward-cache forward-invalidate (+ start size) (- size)) @@ -186,8 +186,7 @@ (lambda (start size) (super-after-delete start size) (end-edit-sequence) - (highlight-parens) - (super-after-delete))] + (highlight-parens))] [on-set-size-constraint (lambda () (and (super-on-set-size-constraint) @@ -200,7 +199,8 @@ (super-after-set-size-constraint))] [after-set-position (lambda () - (highlight-parens))]) + (highlight-parens) + (super-after-set-position))]) (private [highlight-parens? (preferences:get 'framework:highlight-parens)] @@ -212,12 +212,17 @@ [find-enclosing-paren (lambda (pos) (let loop ([pos pos]) - (let ([paren-pos (apply max (map (lambda (pair) (find-string (car pair) -1 pos -1 #f)) + (let ([paren-pos (apply max (map (lambda (pair) (find-string + (car pair) + 'backward + pos + 'eof + #f)) (scheme-paren:get-paren-pairs)))]) (cond [(= -1 paren-pos) #f] [else - (let ([semi-pos (find-string ";" -1 paren-pos)]) + (let ([semi-pos (find-string ";" 'backward paren-pos)]) (cond [(or (= -1 semi-pos) (< semi-pos (paragraph-start-position @@ -266,7 +271,8 @@ (let-values ([(left right) (cond - [(is-right-paren? (get-character (sub1 here))) + [(and (> here 0) + (is-right-paren? (get-character (sub1 here)))) (cond [(slash? (- here 2) (- here 1)) (k (void))] [(scheme-paren:backward-match @@ -643,7 +649,7 @@ (lambda (paren-pair) (find-string (car paren-pair) - -1 + 'backward exp-pos))]) (if (and exp-pos (> exp-pos 0)) diff --git a/collects/framework/splash.ss b/collects/framework/splash.ss index 14188d86..aa0d8834 100644 --- a/collects/framework/splash.ss +++ b/collects/framework/splash.ss @@ -3,7 +3,7 @@ (lambda (filename title width-default depth-default) (let/ec k - (let*-values + (letrec-values ([(no-splash) (lambda () (k void void void))] [(splash-get-resource) (lambda (name default) @@ -15,7 +15,7 @@ (lambda (name value) (write-resource "mred" name value (find-graphical-system-path 'setup-file)) )] - [(_) + [(_1) (begin (unless filename (no-splash)) @@ -25,7 +25,7 @@ [(splash-width-resource) (format "~a-splash-max-width" title)] [(splash-depth-resource) (format "~a-splash-max-depth" title)] - [(splash-max-width) (splash-get-resource splash-width-resource width-default)] + [(splash-max-width) (max 1 (splash-get-resource splash-width-resource width-default))] [(splash-max-depth) (splash-get-resource splash-depth-resource depth-default)] [(splash-sofar-depth) 0] @@ -69,10 +69,10 @@ [(string-ci=? "pict" suffix) 'pict] [else 'xpm]))))] [(bitmap) (make-object bitmap% filename bitmap-flag)] - [(_) (unless (send bitmap ok?) + [(_2) (unless (send bitmap ok?) (fprintf (current-error-port) "WARNING: bad bitmap ~s" filename) (no-splash))] - [(canvas%) + [(splash-canvas%) (class canvas% args (inherit get-dc) (override @@ -85,10 +85,14 @@ (if (get-resource "mred" "splashMessages" b) (not (zero? (unbox b))) #f))] - [(logo-canvas) (make-object canvas% frame)] + [(panel) (make-object vertical-panel% frame)] + [(logo-canvas) (make-object splash-canvas% panel)] [(h-panel) (make-object (if show-messages? horizontal-panel% vertical-panel%) - frame)] - [(gauge) (make-object gauge% #f splash-max-width h-panel '(vertical))] + panel)] + [(gauge) (make-object gauge% #f splash-max-width h-panel + (if show-messages? + '(vertical) + '(horizontal)))] [(v-panel) (make-object vertical-panel% h-panel)] [(splash-messages) (and show-messages? @@ -102,9 +106,12 @@ (loop (sub1 n)))]))]) (send (car msgs) set-label (format "Welcome to ~a" title)) msgs))] - [(_) (begin - (send frame set-alignment 'left 'center) - (send v-panel set-alignment 'left 'top) + [(_3) (begin + (send frame set-alignment 'center 'center) + (send panel stretchable-width show-messages?) + (send panel stretchable-height #f) + (send h-panel set-alignment 'center 'top) + (send v-panel set-alignment 'left 'center) (send logo-canvas min-width (send bitmap get-width)) (send logo-canvas min-height (send bitmap get-height)) (send logo-canvas stretchable-width #f) @@ -137,19 +144,26 @@ [(splash-load-handler) (let ([depth 0]) (lambda (old-load f) - (let ([finalf (splitup-path f)]) - (set! splash-sofar-depth (max (+ depth 1) splash-sofar-depth)) - (set! splash-current-width (+ splash-current-width 1)) - (when (change-splash-message (format "Loading ~a..." finalf) depth #f) - (when (<= splash-current-width splash-max-width) - (send gauge set-value splash-current-width))) - (set! depth (+ depth 1)) - (begin0 - (old-load f) - (begin (set! depth (- depth 1)) - (change-splash-message (format "Loading ~a...done." finalf) - depth #t))))))] - [(_) (current-load + (let ([error? #t] + [finalf (splitup-path f)]) + (dynamic-wind + (lambda () (void)) + (lambda () + (set! splash-sofar-depth (max (+ depth 1) splash-sofar-depth)) + (set! splash-current-width (+ splash-current-width 1)) + (when (change-splash-message (format "Loading ~a..." finalf) depth #f) + (when (<= splash-current-width splash-max-width) + (send gauge set-value splash-current-width))) + (set! depth (+ depth 1)) + (begin0 (old-load f) + (set! error? #f))) + (lambda () + (if error? + (shutdown-splash) + (begin (set! depth (- depth 1)) + (change-splash-message (format "Loading ~a...done." finalf) + depth #t))))))))] + [(_4) (current-load (let ([old-load (current-load)]) (lambda (f) (splash-load-handler old-load f))))] @@ -157,7 +171,7 @@ (lambda () (set! splash-load-handler (lambda (old-load f) (old-load f))) (unless (= splash-max-width splash-current-width) - (set-resource splash-width-resource splash-current-width)) + (set-resource splash-width-resource (max 1 splash-current-width))) (unless (= splash-max-depth splash-sofar-depth) (set-resource splash-depth-resource splash-sofar-depth)))] [(close-splash) diff --git a/collects/framework/text.ss b/collects/framework/text.ss index 0d8fd32e..c7080062 100644 --- a/collects/framework/text.ss +++ b/collects/framework/text.ss @@ -204,7 +204,7 @@ [color (let* ([rc (rectangle-color rectangle)] [tmpc (make-object color% 0 0 0)]) (if rc - (begin (send dc try-colour rc tmpc) + (begin (send dc try-color rc tmpc) (and (<= (max (abs (- (send rc red) (send tmpc red))) (abs (- (send rc blue) (send tmpc blue))) (abs (- (send rc green) (send tmpc green)))) @@ -224,8 +224,8 @@ (let/ec k (cond [(and before color) - (send pen set-colour color) - (send brush set-colour color)] + (send pen set-color color) + (send brush set-color color)] [(and (not before) (not color) b/w-bitmap) (send pen set-stipple b/w-bitmap) (send brush set-stipple b/w-bitmap)] @@ -496,7 +496,7 @@ (when (and (or (eq? format 'same) (eq? format 'copy)) (not (eq? (get-file-format) - 'std))) + 'standard))) (cond [(eq? format 'copy) (set! restore-file-format @@ -504,11 +504,11 @@ (lambda () (set! restore-file-format void) (set-file-format f)))) - (set-file-format 'std)] + (set-file-format 'standard)] [(and (has-non-string-snips) (or (not (preferences:get 'framework:verify-change-format)) (gui-utils:get-choice "Save this file as plain text?" "No" "Yes"))) - (set-file-format 'std)] + (set-file-format 'standard)] [else (void)])) (or (super-on-save-file name format) (begin