From 422acdfbb521bdfbeb7e9b6838018e43a0f5c39e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 18 Sep 2001 02:09:02 +0000 Subject: [PATCH] ... original commit: a6ce24ee031d71a739a111cd2ae68d44b3745321 --- collects/framework/private/exit.ss | 25 +++++++++++-------- collects/framework/private/icon.ss | 24 +++++++++--------- .../framework/private/standard-menus-items.ss | 18 ++++++------- collects/framework/splash.ss | 10 ++++---- 4 files changed, 41 insertions(+), 36 deletions(-) diff --git a/collects/framework/private/exit.ss b/collects/framework/private/exit.ss index 6f048566..6dcc9991 100644 --- a/collects/framework/private/exit.ss +++ b/collects/framework/private/exit.ss @@ -5,7 +5,8 @@ "sig.ss" "../gui-utils-sig.ss" (lib "mred-sig.ss" "mred") - (lib "file.ss")) + (lib "file.ss") + (lib "etc.ss")) (provide exit@) @@ -45,8 +46,11 @@ (define exiting? #f) - (define (can-exit?) (and (user-oks-exit) - (andmap (lambda (cb) (cb)) can?-callbacks))) + (define can-exit? + (opt-lambda ([skip-user-query? #f]) + (and (or skip-user-query? + (user-oks-exit)) + (andmap (lambda (cb) (cb)) can?-callbacks)))) (define (on-exit) (for-each (lambda (cb) (cb)) on-callbacks)) (define (user-oks-exit) @@ -65,10 +69,11 @@ user-says) #t)) - (define (-exit) - (unless exiting? - (set! exiting? #t) - (when (can-exit?) - (on-exit) - (queue-callback (lambda () (exit)))) - (set! exiting? #f)))))) + (define -exit + (opt-lambda ([skip-user-query? #f]) + (unless exiting? + (set! exiting? #t) + (when (can-exit? skip-user-query?) + (on-exit) + (queue-callback (lambda () (exit)))) + (set! exiting? #f))))))) diff --git a/collects/framework/private/icon.ss b/collects/framework/private/icon.ss index 5092e826..17c99a7c 100644 --- a/collects/framework/private/icon.ss +++ b/collects/framework/private/icon.ss @@ -56,21 +56,21 @@ (begin (set! icon (make-object bitmap% p type)) icon))))) - - (define (make-cursor name fallback) - (let ([csr (make-object cursor% - (build-path (collection-path "icons") name) - 'gif - 8 - 8)]) - (if (send csr ok?) - csr - (make-object cursor% fallback)))) + (define (make-cursor name mask fallback) + (let* ([msk-b (make-object bitmap% (build-path (collection-path "icons") mask))] + [csr-b (make-object bitmap% (build-path (collection-path "icons") name))]) + (if (and (send msk-b ok?) + (send csr-b ok?)) + (let ([csr (make-object cursor% msk-b csr-b 7 7)]) + (if (send csr ok?) + csr + (make-object cursor% fallback))) + (make-object cursor% fallback)))) - (define up/down-cursor (make-cursor "up-down-cursor.gif" 'size-n/s)) + (define up/down-cursor (make-cursor "up-down-cursor.xbm" "up-down-mask.xbm" 'size-n/s)) (define (get-up/down-cursor) up/down-cursor) - (define left/right-cursor (make-cursor "left-right-cursor.gif" 'size-e/w)) + (define left/right-cursor (make-cursor "left-right-cursor.xbm" "left-right-mask.xbm" 'size-e/w)) (define (get-left/right-cursor) left/right-cursor) (define gc-on-bitmap #f) diff --git a/collects/framework/private/standard-menus-items.ss b/collects/framework/private/standard-menus-items.ss index 7751886f..d992a7c4 100644 --- a/collects/framework/private/standard-menus-items.ss +++ b/collects/framework/private/standard-menus-items.ss @@ -36,19 +36,19 @@ items) (define-struct generic (name initializer)) - (define-struct (generic/docs struct:generic) (documentation)) - (define-struct (generic-override struct:generic/docs) ()) - (define-struct (generic-method struct:generic/docs) ()) - (define-struct (generic-private-field struct:generic) ()) + (define-struct (generic/docs generic) (documentation)) + (define-struct (generic-override generic/docs) ()) + (define-struct (generic-method generic/docs) ()) + (define-struct (generic-private-field generic) ()) (define-struct menu-item (menu-name)) (define (menu-name->get-menu-name menu-item) (string->symbol (format "get-~a" (menu-item-menu-name menu-item)))) - (define-struct (before/after struct:menu-item) (name procedure)) - (define-struct (before struct:before/after) ()) - (define-struct (after struct:before/after) ()) + (define-struct (before/after menu-item) (name procedure)) + (define-struct (before before/after) ()) + (define-struct (after before/after) ()) (define (before/after->name before/after) (string->symbol (format "~a:~a-~a" (menu-item-menu-name before/after) @@ -57,14 +57,14 @@ "after") (before/after-name before/after)))) - (define-struct (between struct:menu-item) (before after procedure)) + (define-struct (between menu-item) (before after procedure)) (define (between->name between) (string->symbol (format "~a:between-~a-and-~a" (menu-item-menu-name between) (between-before between) (between-after between)))) - (define-struct (an-item struct:menu-item) + (define-struct (an-item menu-item) (item-name help-string proc diff --git a/collects/framework/splash.ss b/collects/framework/splash.ss index 78e2a930..244a8d36 100644 --- a/collects/framework/splash.ss +++ b/collects/framework/splash.ss @@ -64,24 +64,24 @@ (send splash-frame show #f))) (define (shutdown-splash) - (set! splash-load-handler (lambda (old-load f) (old-load f)))) + (set! splash-load-handler (lambda (old-load f expected) (old-load f expected)))) (define funny? (let ([date (seconds->date (current-seconds))]) (and (= (date-day date) 25) (= (date-month date) 12)))) - (define (splash-load-handler old-load f) + (define (splash-load-handler old-load f expected) (let ([finalf (splitup-path f)]) (set! splash-current-width (+ splash-current-width 1)) (when (<= splash-current-width splash-max-width) (send gauge set-value splash-current-width)) - (old-load f))) + (old-load f expected))) (current-load (let ([old-load (current-load)]) - (lambda (f) - (splash-load-handler old-load f)))) + (lambda (f expected) + (splash-load-handler old-load f expected)))) (define funny-gauge% (class100 canvas% (parent)