ffi/unsafe/obj: add +A' and -A' method modes

mflatt · mflatt · commit 57516164de98 · 2013-04-19T07:54:30.000-06:00
On Cocoa, a view's `drawRect:' method can be called from a
heartbeat thread that animates controls. Such a call happens
rarely for a `canvas%' or other class where `drawRect:'
is overridden, but since it can happen, ensure that the
callback runs on the Racket thread.
diff --git a/collects/ffi/unsafe/objc.rkt b/collects/ffi/unsafe/objc.rkt
@@ -756,11 +756,14 @@
           (or (free-identifier=? #'kind #'+)
               (free-identifier=? #'kind #'-)
               (free-identifier=? #'kind #'+a)
-              (free-identifier=? #'kind #'-a))
+              (free-identifier=? #'kind #'-a)
+              (free-identifier=? #'kind #'+A)
+              (free-identifier=? #'kind #'-A))
           (let ([id #'id]
                 [args (syntax->list #'(arg ...))]
                 [in-class? (or (free-identifier=? #'kind #'+)
-                               (free-identifier=? #'kind #'+a))])
+                               (free-identifier=? #'kind #'+a)
+                               (free-identifier=? #'kind #'+A))])
             (when (null? args)
               (unless (identifier? id)
                 (raise-syntax-error #f
@@ -787,15 +790,19 @@
                                    [_ (error "oops")])
                                  '())]
                             [(async ...)
-                             (if (eq? (syntax-e id) 'dealloc)
-                                 ;; so that objects can be destroyed in foreign threads:
+                             (if (or (free-identifier=? #'kind #'+A)
+                                     (free-identifier=? #'kind #'-A)
+                                     ;; so that objects can be destroyed in foreign threads:
+                                     (eq? (syntax-e id) 'dealloc))
                                  #'(#:async-apply apply-directly)
                                  #'())]
                             [in-cls (if in-class?
                                         #'(object-get-class cls)
                                         #'cls)]
                             [atomic? (or (free-identifier=? #'kind #'+a)
-                                         (free-identifier=? #'kind #'-a))])
+                                         (free-identifier=? #'kind #'-a)
+                                         (free-identifier=? #'kind #'+A)
+                                         (free-identifier=? #'kind #'-A))])
                 (quasisyntax/loc stx
                   (let ([rt result-type]
                         [arg-id arg-type] ...)
diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt
@@ -65,7 +65,7 @@
 (define-objc-mixin (RacketViewMixin Superclass)
   #:mixins (KeyMouseTextResponder CursorDisplayer FocusResponder) 
   [wxb]
-  (-a _void (drawRect: [_NSRect r])
+  (-A _void (drawRect: [_NSRect r])
       (when wxb
         (let ([wx (->wx wxb)])
           (when wx
@@ -98,7 +98,7 @@
 
 (define-objc-class CornerlessFrameView NSView 
   []
-  (-a _void (drawRect: [_NSRect r])
+  (-A _void (drawRect: [_NSRect r])
       (let ([ctx (tell NSGraphicsContext currentContext)])
         (tellv ctx saveGraphicsState)
         (let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
@@ -129,7 +129,7 @@
   [on?]
   (-a _void (setFocusState: [_BOOL is-on?])
       (set! on? is-on?))
-  (-a _void (drawRect: [_NSRect r])
+  (-A _void (drawRect: [_NSRect r])
       (let ([f (tell #:type _NSRect self frame)])
         (tellv bezel-cell 
                drawWithFrame: #:type _NSRect (make-NSRect (make-NSPoint 2 2)
@@ -154,7 +154,7 @@
   #:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer) 
   #:protocols (NSComboBoxDelegate)
   [wxb]
-  (-a _void (drawRect: [_NSRect r])
+  (-A _void (drawRect: [_NSRect r])
       (super-tell #:type _void drawRect: #:type _NSRect r)
       (let ([wx (->wx wxb)])
         (when wx
diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt
@@ -22,7 +22,7 @@
 
 (define-objc-class FrameView NSView 
   []
-  (-a _void (drawRect: [_NSRect r])
+  (-A _void (drawRect: [_NSRect r])
       (let ([ctx (tell NSGraphicsContext currentContext)])
         (tellv ctx saveGraphicsState)
         (let ([cg (tell #:type _CGContextRef ctx graphicsPort)]
diff --git a/collects/scribblings/foreign/objc.scrbl b/collects/scribblings/foreign/objc.scrbl
@@ -138,7 +138,7 @@ Defines each @racket[protocol-id] to the protocol (a value with FFI type
 (eval:alts (import-protocol NSCoding) (void))
 ]}
 
-@defform/subs[#:literals (+ - +a -a)
+@defform/subs[#:literals (+ - +a -a +A -A)
               (define-objc-class class-id superclass-expr
                 maybe-mixins
                 maybe-protocols
@@ -150,7 +150,7 @@ Defines each @racket[protocol-id] to the protocol (a value with FFI type
                                 (code:line #:protocols (protocol-expr ...))]
                [method (mode result-ctype-expr (method-id) body ...+)
                        (mode result-ctype-expr (arg ...+) body ...+)]
-               [mode + - +a -a]
+               [mode + - +a -a +A -A]
                [arg (code:line method-id [ctype-expr arg-id])])]{
 
 Defines @racket[class-id] as a new, registered Objective-C class (of
@@ -167,12 +167,17 @@ directly when the method @racket[body]s. Outside the object, they can
 be referenced and set with @racket[get-ivar] and @racket[set-ivar!].
 
 Each @racket[method] adds or overrides a method to the class (when
-@racket[mode] is @racket[-] or @racket[-a]) to be called on instances,
+@racket[mode] is @racket[-], @racket[-a], or @racket[-A]) to be called on instances,
 or it adds a method to the meta-class (when @racket[mode] is
-@racket[+] or @racket[+a]) to be called on the class itself. All
+@racket[+], @racket[+a], or @racket[+A]) to be called on the class itself. All
 result and argument types must be declared using FFI C types
 (@seeCtype). When @racket[mode] is @racket[+a] or @racket[-a], the
 method is called in atomic mode (see @racket[_cprocedure]).
+When @racket[mode] is @racket[+A] or @racket[-A], the
+method is called in atomic mode, and it may also be triggered
+as a result of a foreign call in a foreign thread
+thread, in which case the foreign thread must wait until the
+call completes in a Racket thread.
 
 If a @racket[method] is declared with a single @racket[method-id] and
 no arguments, then @racket[method-id] must not end with
diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt
@@ -4,6 +4,7 @@ Changed initialization of current-directory to use PWD
 racket/system: add a #:set-pwd? argument to system, etc., which
  makes them set PWD by default
 net/url: add support for HTTP/1.1 connections
+ffi/unsafe/objc: add -A and +A method modes
 
 Version 5.3.4.2
 Added current-environment-variables, environment-variables-ref,
