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

clean up cocoa memory management and also fix vertical sliders and guages

Browse Source 
original commit: 152a8b67039ba64e8945ffa513c91f2dafa8e99d
This commit is contained in:
Matthew Flatt 2010-08-14 20:33:30 -06:00
parent 865a4b4671
commit 2197b56aab
11 changed files with 73 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/mred/private/wx/cocoa/button.rkt
View File

@ -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)

16
collects/mred/private/wx/cocoa/frame.rkt
View File

@ -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)]

21
collects/mred/private/wx/cocoa/gauge.rkt
View File

@ -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)])

10
collects/mred/private/wx/cocoa/list-box.rkt
View File

@ -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:

11
collects/mred/private/wx/cocoa/menu-item.rkt
View File

@ -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))

3
collects/mred/private/wx/cocoa/pool.rkt
View File

@ -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))

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

@ -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))))

5
collects/mred/private/wx/cocoa/slider.rkt
View File

@ -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)]

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

@ -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

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

@ -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))))

23
collects/mred/private/wxlitem.rkt
View File

@ -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