diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 466382e8..dbff38f0 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -79,11 +79,12 @@ (send label get-width))] [new-height (max (NSSize-height (NSRect-size frame)) (send label get-height))]) - (let ([cocoa (tell (tell NSView alloc) - initWithFrame: #:type _NSRect - (make-NSRect (NSRect-origin frame) - (make-NSSize new-width - new-height)))] + (let ([cocoa (as-objc-allocation + (tell (tell NSView alloc) + initWithFrame: #:type _NSRect + (make-NSRect (NSRect-origin frame) + (make-NSSize new-width + new-height))))] [image-cocoa (as-objc-allocation (tell (tell NSImageView alloc) init))]) (tellv cocoa addSubview: button-cocoa) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 39b18c8d..39510db6 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -229,14 +229,14 @@ endSheet: cocoa)))) (tellv cocoa orderOut: #f) (let ([next - (let* ([pool (tell (tell NSAutoreleasePool alloc) init)] - [wins (tell (tell NSApplication sharedApplication) orderedWindows)]) - (begin0 - (for/or ([i (in-range (tell #:type _NSUInteger wins count))]) - (let ([win (tell wins objectAtIndex: #:type _NSUInteger i)]) - (and (tell #:type _BOOL win isVisible) - win))) - (tellv pool release)))]) + (atomically + (with-autorelease + (let ([wins (tell (tell NSApplication sharedApplication) orderedWindows)]) + (begin0 + (for/or ([i (in-range (tell #:type _NSUInteger wins count))]) + (let ([win (tell wins objectAtIndex: #:type _NSUInteger i)]) + (and (tell #:type _BOOL win isVisible) + win)))))))]) (cond [next (tellv next makeKeyWindow)] [root-fake-frame (send root-fake-frame install-mb)] diff --git a/collects/mred/private/wx/cocoa/gauge.rkt b/collects/mred/private/wx/cocoa/gauge.rkt index 32241caa..04be1294 100644 --- a/collects/mred/private/wx/cocoa/gauge.rkt +++ b/collects/mred/private/wx/cocoa/gauge.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/class scheme/foreign + racket/math ffi/objc "../../syntax.rkt" "item.rkt" @@ -18,7 +19,7 @@ (import-class NSProgressIndicator) (define-objc-class MyProgressIndicator NSProgressIndicator - #:mixins () + #:mixins (KeyMouseResponder) [wxb]) (defclass gauge% item% @@ -31,16 +32,22 @@ (inherit get-cocoa) (super-new [parent parent] - [cocoa (let ([cocoa (tell (tell MyProgressIndicator alloc) init)]) + [cocoa (let ([cocoa (as-objc-allocation + (tell (tell MyProgressIndicator alloc) init))]) (tellv cocoa setIndeterminate: #:type _BOOL #f) (tellv cocoa setMaxValue: #:type _double* rng) (tellv cocoa setDoubleValue: #:type _double* 0.0) - #; - (tellv cocoa setFrame: #:type _NSRect (make-NSRect - (make-NSPoint 0 0) - (make-NSSize (if vert? 24 32) - (if vert? 32 24)))) (tellv cocoa sizeToFit) + (when (memq 'vertical style) + (let ([r (tell #:type _NSRect cocoa frame)]) + (printf "height ~s\n" (NSSize-height (NSRect-size r))) + (tellv cocoa setFrame: + #:type _NSRect (make-NSRect + (NSRect-origin r) + (make-NSSize + (NSSize-height (NSRect-size r)) + (NSSize-width (NSRect-size r))))) + (tellv cocoa rotateByAngle: #:type _CGFloat -90))) cocoa)] [callback void] [no-show? (memq 'deleted style)]) diff --git a/collects/mred/private/wx/cocoa/list-box.rkt b/collects/mred/private/wx/cocoa/list-box.rkt index 5495e8b3..6b86fd00 100644 --- a/collects/mred/private/wx/cocoa/list-box.rkt +++ b/collects/mred/private/wx/cocoa/list-box.rkt @@ -26,8 +26,10 @@ [wxb] [-a _id (preparedCellAtColumn: [_NSInteger column] row: [_NSInteger row]) (let ([wx (->wx wxb)]) - (tell (tell NSCell alloc) initTextCell: #:type _NSString - (if wx (send wx get-row row) "???")))] + (tell + (tell (tell NSCell alloc) initTextCell: #:type _NSString + (if wx (send wx get-row row) "???")) + autorelease))] [-a _void (doubleClicked: [_id sender]) (queue-window*-event wxb (lambda (wx) (send wx clicked 'list-box-dclick)))] [-a _void (tableViewSelectionDidChange: [_id aNotification]) @@ -70,8 +72,8 @@ (define cocoa (as-objc-allocation (tell (tell NSScrollView alloc) init))) (define content-cocoa (let ([content-cocoa - (as-objc-allocation - (tell (tell MyTableView alloc) init))]) + (as-objc-allocation + (tell (tell MyTableView alloc) init))]) (tellv content-cocoa setDelegate: content-cocoa) (tellv content-cocoa setDataSource: source) (tellv content-cocoa addTableColumn: diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt index 2e532ebb..2356214c 100644 --- a/collects/mred/private/wx/cocoa/menu-item.rkt +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -50,10 +50,11 @@ (define/public (install menu) (if submenu (send submenu install menu label) - (let ([item (tell (tell MyMenuItem alloc) - initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "") - action: #:type _SEL #f - keyEquivalent: #:type _NSString "")]) + (let ([item (as-objc-allocation + (tell (tell MyMenuItem alloc) + initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "") + action: #:type _SEL #f + keyEquivalent: #:type _NSString ""))]) (set-ivar! item wxb (->wxb this)) (tellv menu addItem: item) (tellv item setEnabled: #:type _BOOL enabled?) @@ -78,6 +79,6 @@ NSCommandKeyMask))]) (tellv item setKeyEquivalent: #:type _NSString s) (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods)))) - (tellv item release)))) + (release item)))) (super-new)) diff --git a/collects/mred/private/wx/cocoa/pool.rkt b/collects/mred/private/wx/cocoa/pool.rkt index 4f021023..aff29ab9 100644 --- a/collects/mred/private/wx/cocoa/pool.rkt +++ b/collects/mred/private/wx/cocoa/pool.rkt @@ -11,4 +11,7 @@ (import-class NSAutoreleasePool) +;; This pool manages all objects that would otherwise not +;; have a pool, which makes them stick around until the +;; process exits. (define pool (tell (tell NSAutoreleasePool alloc) init)) diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 9d2f8813..abef5c0c 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -230,8 +230,10 @@ (queue-event e (lambda () (call-as-nonatomic-retry-point (lambda () - (tellv app sendEvent: evt) - (release evt)))))) + ;; in atomic mode + (with-autorelease + (tellv app sendEvent: evt) + (release evt))))))) (tellv app sendEvent: evt))) #t))) (tellv pool release)))) diff --git a/collects/mred/private/wx/cocoa/slider.rkt b/collects/mred/private/wx/cocoa/slider.rkt index 92dd980a..19f086bb 100644 --- a/collects/mred/private/wx/cocoa/slider.rkt +++ b/collects/mred/private/wx/cocoa/slider.rkt @@ -43,7 +43,8 @@ (inherit get-cocoa) (super-new [parent parent] - [cocoa (let ([cocoa (tell (tell MySlider alloc) init)] + [cocoa (let ([cocoa (as-objc-allocation + (tell (tell MySlider alloc) init))] [vert? (memq 'vertical style)]) (tellv cocoa setMinValue: #:type _double* lo) (tellv cocoa setMaxValue: #:type _double* hi) @@ -53,7 +54,7 @@ (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint 0 0) (make-NSSize (if vert? 24 32) - (if vert? 32 24)))) + (if vert? 64 24)))) (tellv cocoa setContinuous: #:type _BOOL #t) ; (tellv cocoa sizeToFit) cocoa)] diff --git a/collects/mred/private/wx/cocoa/types.rkt b/collects/mred/private/wx/cocoa/types.rkt index fed4632b..accaffc8 100644 --- a/collects/mred/private/wx/cocoa/types.rkt +++ b/collects/mred/private/wx/cocoa/types.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require ffi/objc scheme/foreign + "../../lock.rkt" "utils.rkt") (unsafe!) (objc-unsafe!) @@ -51,9 +52,10 @@ (hash-set! strings v s) s))) (lambda (v) - (with-autorelease + (atomically + (with-autorelease (let ([s (tell #:type _bytes v UTF8String)]) - (bytes->string/utf-8 s)))))) + (bytes->string/utf-8 s))))))) (define NSNotFound (if 64-bit? #x7fffffffffffffff diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index 72167b6c..a4486769 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -41,11 +41,12 @@ (import-class NSAutoreleasePool) -(define-syntax-rule (with-autorelease expr) - (call-with-autorelease (lambda () expr))) +;; Use `with-autorelease' and `call-with-autorelease' +;; in atomic mode +(define-syntax-rule (with-autorelease expr ...) + (call-with-autorelease (lambda () expr ...))) (define (call-with-autorelease thunk) - (let ([pool (as-objc-allocation - (tell (tell NSAutoreleasePool alloc) init))]) + (let ([pool (tell (tell NSAutoreleasePool alloc) init)]) (begin0 (thunk) (release pool)))) diff --git a/collects/mred/private/wxlitem.rkt b/collects/mred/private/wxlitem.rkt index 597b3a62..5b507d9e 100644 --- a/collects/mred/private/wxlitem.rkt +++ b/collects/mred/private/wxlitem.rkt @@ -67,17 +67,17 @@ (unless (memq 'deleted style) (send (area-parent) add-child this)) (define horiz? (is-horiz? style parent)) - (define p (make-sub horiz? proxy this 'left valign)) + (define p (make-sub horiz? proxy this (if horiz? 'left 'center) valign)) (define l (make-label label proxy p font)) (define/public (set-label s) (when l (send l set-label s))) (define/public (get-label) (and l (send l get-label))) (define/public (get-p) p) - (define/public (set-c v) + (define/public (set-c v sx? sy?) (set! c v) - (send c stretchable-in-x #t) - (send c stretchable-in-y #t) + (send c stretchable-in-x sx?) + (send c stretchable-in-y sy?) (send c skip-subwindow-events? #t)))) ;; ---------------------------------------- @@ -100,7 +100,7 @@ (define c (make-object wx-internal-choice% mred proxy (get-p) cb label x y w h choices (filter-style style) font)) - (set-c c) + (set-c c #t #f) (bounce c @@ -158,7 +158,7 @@ (define c (make-object wx-internal-list-box% mred proxy (get-p) cb label kind x y w h choices (filter-style style) font label-font)) - (set-c c) + (set-c c #t #t) (bounce c @@ -231,7 +231,7 @@ (define c (make-object wx-internal-radio-box% mred proxy (get-p) cb label x y w h choices major (filter-style style) font)) - (set-c c) + (set-c c #t #t) (define/override enable (case-lambda @@ -306,7 +306,9 @@ (define c (make-object wx-internal-gauge% mred proxy (get-p) label range (filter-style style) font)) - (set-c c) + (set-c c + (memq 'horizontal style) + (memq 'vertical style)) (bounce c @@ -362,7 +364,10 @@ (define c (make-object wx-internal-slider% mred proxy (get-p) func label value min-val max-val (filter-style style) font)) - (set-c c) + + (set-c c + (memq 'horizontal style) + (memq 'vertical style)) (bounce c