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

original commit: 152a8b67039ba64e8945ffa513c91f2dafa8e99d

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)
+                      (let ([cocoa (as-objc-allocation
+                                    (tell (tell NSView alloc)
                                           initWithFrame: #:type _NSRect
                                           (make-NSRect (NSRect-origin frame)
                                                        (make-NSSize new-width
-                                                                   new-height)))]
+                                                                    new-height))))]
                             [image-cocoa (as-objc-allocation
                                           (tell (tell NSImageView alloc) init))])
                         (tellv cocoa addSubview: button-cocoa)

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)]
+                      (atomically
-                             [wins (tell (tell NSApplication sharedApplication) orderedWindows)])
+                       (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)))
+                                    win)))))))])
-                         (tellv pool release)))])
                  (cond
                   [next (tellv next makeKeyWindow)]
                   [root-fake-frame (send root-fake-frame install-mb)]

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

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 (tell NSCell alloc) initTextCell: #:type _NSString 
-              (if wx (send wx get-row row) "???")))]
+               (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])

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) 
+        (let ([item (as-objc-allocation
+                     (tell (tell MyMenuItem alloc) 
                            initWithTitle: #:type _NSString (regexp-replace #rx"\t.*" label "")
                            action: #:type _SEL #f
-                          keyEquivalent: #:type _NSString "")])
+                           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))

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

collects/mred/private/wx/cocoa/queue.rkt

@@ -230,8 +230,10 @@
                         (queue-event e (lambda () 
                                          (call-as-nonatomic-retry-point
                                           (lambda ()
+                                            ;; in atomic mode
+                                            (with-autorelease
                                              (tellv app sendEvent: evt)
-                                            (release evt))))))
+                                             (release evt)))))))
                       (tellv app sendEvent: evt)))
                 #t)))
      (tellv pool release))))

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

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)
+                                (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

collects/mred/private/wx/cocoa/utils.rkt

@@ -41,11 +41,12 @@
 
 (import-class NSAutoreleasePool)
 
-(define-syntax-rule (with-autorelease expr)
+;; Use `with-autorelease' and `call-with-autorelease' 
-  (call-with-autorelease (lambda () expr)))
+;; in atomic mode
+(define-syntax-rule (with-autorelease expr ...)
+  (call-with-autorelease (lambda () expr ...)))
 (define (call-with-autorelease thunk)
-  (let ([pool (as-objc-allocation
+  (let ([pool (tell (tell NSAutoreleasePool alloc) init)])
-               (tell (tell NSAutoreleasePool alloc) init))])
     (begin0
      (thunk)
      (release pool))))

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-x sx?)
-        (send c stretchable-in-y #t)
+        (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