suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cocoa allocation repairs

Browse Source
This commit is contained in:
Matthew Flatt 2010-09-10 21:14:12 -06:00
parent 5117d09473
commit 227300dc94
3 changed files with 31 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/mred/private/wx/cocoa/filedialog.rkt
View File

@ -19,15 +19,13 @@
(define (file-selector message directory filename (define (file-selector message directory filename
extension extension
filters style parent) filters style parent)
(let ([ns (if (memq 'put style) (let ([ns (as-objc-allocation-with-retain
(if (memq 'put style)
(tell NSSavePanel savePanel) (tell NSSavePanel savePanel)
(tell NSOpenPanel openPanel))] (tell NSOpenPanel openPanel)))]
[parent (and parent [parent (and parent
(not (send parent get-sheet)) (not (send parent get-sheet))
parent)]) parent)])
;; Why? This looks like a leak, but we get crashes
;; without it.
(retain ns)
(let ([extensions (append (let ([extensions (append
(if extension (list extension) null) (if extension (list extension) null)
@ -84,12 +82,14 @@
(when parent (tell app endSheet: ns)) (when parent (tell app endSheet: ns))
(when front (tellv (send front get-cocoa-window) (when front (tellv (send front get-cocoa-window)
makeKeyAndOrderFront: #f)))))]) makeKeyAndOrderFront: #f)))))])
(if (zero? result) (begin0
#f (if (zero? result)
(if (memq 'multi style) #f
(let ([urls (tell ns URLs)]) (if (memq 'multi style)
(for/list ([i (in-range (tell #:type _NSUInteger urls count))]) (let ([urls (tell ns URLs)])
(nsurl->string (tell urls objectAtIndex: #:type _NSUInteger i)))) (for/list ([i (in-range (tell #:type _NSUInteger urls count))])
(let ([url (tell ns URL)]) (nsurl->string (tell urls objectAtIndex: #:type _NSUInteger i))))
(nsurl->string url))))))) (let ([url (tell ns URL)])
(nsurl->string url))))
(release ns)))))

22
collects/mred/private/wx/cocoa/procs.rkt
View File

@ -125,18 +125,20 @@
(define-cocoa NSCalibratedRGBColorSpace _id) (define-cocoa NSCalibratedRGBColorSpace _id)
(define (get-highlight-background-color) (define (get-highlight-background-color)
(let ([hi (tell (tell NSColor selectedTextBackgroundColor) (let ([hi (as-objc-allocation-with-retain
colorUsingColorSpaceName: NSCalibratedRGBColorSpace)] (tell (tell NSColor selectedTextBackgroundColor)
colorUsingColorSpaceName: NSCalibratedRGBColorSpace))]
[as-color (lambda (v) [as-color (lambda (v)
(inexact->exact (floor (* 255.0 v))))]) (inexact->exact (floor (* 255.0 v))))])
(unless hi (error "selection background color lookup failed!")) (begin0
(make-object color% (make-object color%
(as-color (as-color
(tell #:type _CGFloat hi redComponent)) (tell #:type _CGFloat hi redComponent))
(as-color (as-color
(tell #:type _CGFloat hi greenComponent)) (tell #:type _CGFloat hi greenComponent))
(as-color (as-color
(tell #:type _CGFloat hi blueComponent))))) (tell #:type _CGFloat hi blueComponent)))
(release hi))))
(define (get-highlight-text-color) (define (get-highlight-text-color)
#f) #f)

6
collects/mred/private/wx/cocoa/utils.rkt
View File

@ -13,6 +13,7 @@
define-appkit define-appkit
define-mz define-mz
as-objc-allocation as-objc-allocation
as-objc-allocation-with-retain
retain release retain release
with-autorelease with-autorelease
clean-menu-label clean-menu-label
@ -37,6 +38,11 @@
(define-syntax-rule (as-objc-allocation expr) (define-syntax-rule (as-objc-allocation expr)
((objc-allocator (lambda () 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 release ((deallocator) objc-delete))
(define retain ((retainer release car) (define retain ((retainer release car)
(lambda (obj) (lambda (obj)