diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 940da2a6..32139d7a 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -221,8 +221,12 @@ (super-instantiate ()) (accept-drop-files #t) - (make-object menu:can-restore-underscore-menu% (string-constant windows-menu-label) - (make-object (get-menu-bar%) this)) + (let ([mb (make-object (get-menu-bar%) this)]) + (when (or (eq? (system-type) 'macos) + (eq? (system-type) 'macosx)) + (make-object menu:can-restore-underscore-menu% (string-constant windows-menu-label) + mb))) + (reorder-menus this) (send (group:get-the-frame-group) insert-frame this) [define panel (make-root-area-container (get-area-container%) this)] diff --git a/collects/framework/private/group.ss b/collects/framework/private/group.ss index 8c4aa256..1dd2340e 100644 --- a/collects/framework/private/group.ss +++ b/collects/framework/private/group.ss @@ -36,6 +36,7 @@ [define windows-menus null] + ;; get-windows-menu : (is-a?/c frame%) -> (union false? (is-a?/c menu%)) [define get-windows-menu (lambda (frame) (let ([menu-bar (send frame get-menu-bar)]) @@ -54,16 +55,17 @@ (set! windows-menus (cons menu windows-menus)))))] [define remove-windows-menu (lambda (frame) - (let* ([menu (get-windows-menu frame)]) + (let ([menu (get-windows-menu frame)]) - ;; to help the (conservative) gc. - (for-each (lambda (i) (send i delete)) (send menu get-items)) + (when menu + ;; to help the (conservative) gc. + (for-each (lambda (i) (send i delete)) (send menu get-items)) - (set! windows-menus - (remove - menu - windows-menus - eq?))))] + (set! windows-menus + (remove + menu + windows-menus + eq?)))))] [define (update-windows-menus) (let* ([windows (length windows-menus)] diff --git a/collects/framework/splash.ss b/collects/framework/splash.ss index 7d3cd28b..939a1acf 100644 --- a/collects/framework/splash.ss +++ b/collects/framework/splash.ss @@ -2,10 +2,13 @@ (module splash mzscheme (require (lib "class.ss") (lib "file.ss") - (lib "mred.ss" "mred")) + (lib "mred.ss" "mred") + (lib "contracts.ss")) - (provide get-splash-bitmap get-splash-canvas get-splash-eventspace get-dropped-files - start-splash shutdown-splash close-splash) + (provide get-splash-bitmap set-splash-bitmap + get-splash-canvas get-splash-eventspace get-dropped-files + start-splash shutdown-splash close-splash add-splash-icon set-splash-char-observer) + (define splash-filename #f) (define splash-bitmap #f) @@ -13,9 +16,22 @@ (define dropped-files null) (define (get-splash-bitmap) splash-bitmap) + (define (set-splash-bitmap bm) + (set! splash-bitmap bm) + (send splash-canvas on-paint)) (define (get-splash-canvas) splash-canvas) (define (get-splash-eventspace) splash-eventspace) (define (get-dropped-files) dropped-files) + + (define char-observer void) + (define (set-splash-char-observer proc) + (set! char-observer proc)) + + (define-struct icon (bm x y)) + (define icons null) + (define (add-splash-icon bm x y) + (set! icons (cons (make-icon bm x y) icons)) + (send splash-canvas on-paint)) (define (start-splash _splash-filename _splash-title width-default) (set! splash-title _splash-title) @@ -170,10 +186,18 @@ (define splash-canvas% (class canvas% (inherit get-dc) + (define/override (on-char evt) (char-observer evt)) (define/override (on-paint) - (if splash-bitmap - (send (get-dc) draw-bitmap splash-bitmap 0 0) - (send (get-dc) clear))) + (let ([dc (get-dc)]) + (if splash-bitmap + (send dc draw-bitmap splash-bitmap 0 0) + (send dc clear)) + (for-each (lambda (icon) + (send dc draw-bitmap + (icon-bm icon) + (icon-x icon) + (icon-y icon))) + icons))) (super-instantiate ()))) (define splash-frame