diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt index 1d19c677..c2bfc8ae 100644 --- a/collects/mred/private/wx/cocoa/filedialog.rkt +++ b/collects/mred/private/wx/cocoa/filedialog.rkt @@ -19,15 +19,13 @@ (define (file-selector message directory filename extension filters style parent) - (let ([ns (if (memq 'put style) + (let ([ns (as-objc-allocation-with-retain + (if (memq 'put style) (tell NSSavePanel savePanel) - (tell NSOpenPanel openPanel))] + (tell NSOpenPanel openPanel)))] [parent (and parent (not (send parent get-sheet)) parent)]) - ;; Why? This looks like a leak, but we get crashes - ;; without it. - (retain ns) (let ([extensions (append (if extension (list extension) null) @@ -84,12 +82,14 @@ (when parent (tell app endSheet: ns)) (when front (tellv (send front get-cocoa-window) makeKeyAndOrderFront: #f)))))]) - (if (zero? result) - #f - (if (memq 'multi style) - (let ([urls (tell ns URLs)]) - (for/list ([i (in-range (tell #:type _NSUInteger urls count))]) - (nsurl->string (tell urls objectAtIndex: #:type _NSUInteger i)))) - (let ([url (tell ns URL)]) - (nsurl->string url))))))) + (begin0 + (if (zero? result) + #f + (if (memq 'multi style) + (let ([urls (tell ns URLs)]) + (for/list ([i (in-range (tell #:type _NSUInteger urls count))]) + (nsurl->string (tell urls objectAtIndex: #:type _NSUInteger i)))) + (let ([url (tell ns URL)]) + (nsurl->string url)))) + (release ns))))) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index a03daccc..374a89a7 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -125,18 +125,20 @@ (define-cocoa NSCalibratedRGBColorSpace _id) (define (get-highlight-background-color) - (let ([hi (tell (tell NSColor selectedTextBackgroundColor) - colorUsingColorSpaceName: NSCalibratedRGBColorSpace)] + (let ([hi (as-objc-allocation-with-retain + (tell (tell NSColor selectedTextBackgroundColor) + colorUsingColorSpaceName: NSCalibratedRGBColorSpace))] [as-color (lambda (v) (inexact->exact (floor (* 255.0 v))))]) - (unless hi (error "selection background color lookup failed!")) - (make-object color% - (as-color - (tell #:type _CGFloat hi redComponent)) - (as-color - (tell #:type _CGFloat hi greenComponent)) - (as-color - (tell #:type _CGFloat hi blueComponent))))) + (begin0 + (make-object color% + (as-color + (tell #:type _CGFloat hi redComponent)) + (as-color + (tell #:type _CGFloat hi greenComponent)) + (as-color + (tell #:type _CGFloat hi blueComponent))) + (release hi)))) (define (get-highlight-text-color) #f) diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index 37c1712c..bc40b320 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -13,6 +13,7 @@ define-appkit define-mz as-objc-allocation + as-objc-allocation-with-retain retain release with-autorelease clean-menu-label @@ -37,6 +38,11 @@ (define-syntax-rule (as-objc-allocation expr) ((objc-allocator (lambda () expr)))) +(define-syntax-rule (as-objc-allocation-with-retain expr) + ((objc-allocator (lambda () (let ([v expr]) + (tellv v retain) + v))))) + (define release ((deallocator) objc-delete)) (define retain ((retainer release car) (lambda (obj)