diff --git a/collects/ffi/unsafe/objc.rkt b/collects/ffi/unsafe/objc.rkt index 5494d90b01..350ed2a580 100644 --- a/collects/ffi/unsafe/objc.rkt +++ b/collects/ffi/unsafe/objc.rkt @@ -750,20 +750,17 @@ (define-syntax (add-method stx) (syntax-case stx () [(_ whole-stx cls superclass-id m) - (let ([stx #'whole-stx]) - (syntax-case #'m () - [(kind result-type (id arg ...) body0 body ...) + (let loop ([stx #'whole-stx] [m #'m]) + (syntax-case m () + [(kind #:async-apply async result-type (id arg ...) body0 body ...) (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 @@ -789,35 +786,37 @@ (super-tell #:type _void dealloc)))] [_ (error "oops")]) '())] - [(async ...) - (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] ...) (void (class_addMethod in-cls (sel_registerName id-str) - #,(syntax/loc #'m + #,(syntax/loc m (lambda (self-id cmd arg-id ...) (syntax-parameterize ([self (make-id-stx #'self-id)] [super-class (make-id-stx #'superclass-id)] [super-tell do-super-tell]) body0 body ... dealloc-body ...))) - (_fun #:atomic? atomic? #:keep save-method! async ... + (_fun #:atomic? atomic? + #:keep save-method! + #:async-apply async _id _id arg-type ... -> rt) (generate-layout rt (list arg-id ...)))))))))] + [(kind result-type (id arg ...) body0 body ...) + (loop stx + (with-syntax ([async + (if (eq? (syntax-e #'id) 'dealloc) + ;; so that objects can be destroyed in foreign threads: + #'apply-directly + #'#f)]) + (syntax/loc m + (kind #:async-apply async result-type (id arg ...) body0 body ...))))] [else (raise-syntax-error #f "bad method form" stx diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index cbb99ea873..6613d6cbb0 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -65,7 +65,8 @@ (define-objc-mixin (RacketViewMixin Superclass) #:mixins (KeyMouseTextResponder CursorDisplayer FocusResponder) [wxb] - (-A _void (drawRect: [_NSRect r]) + (-a #:async-apply (box (void)) + _void (drawRect: [_NSRect r]) (when wxb (let ([wx (->wx wxb)]) (when wx @@ -98,7 +99,8 @@ (define-objc-class CornerlessFrameView NSView [] - (-A _void (drawRect: [_NSRect r]) + (-a #:async-apply (box (void)) + _void (drawRect: [_NSRect r]) (let ([ctx (tell NSGraphicsContext currentContext)]) (tellv ctx saveGraphicsState) (let ([cg (tell #:type _CGContextRef ctx graphicsPort)] @@ -129,7 +131,8 @@ [on?] (-a _void (setFocusState: [_BOOL is-on?]) (set! on? is-on?)) - (-A _void (drawRect: [_NSRect r]) + (-a #:async-apply (box (void)) + _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 +157,8 @@ #:mixins (FocusResponder KeyMouseTextResponder CursorDisplayer) #:protocols (NSComboBoxDelegate) [wxb] - (-A _void (drawRect: [_NSRect r]) + (-a #:async-apply (box (void)) + _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 index 55962b1977..00a91c12bd 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -22,7 +22,8 @@ (define-objc-class FrameView NSView [] - (-A _void (drawRect: [_NSRect r]) + (- #:async-apply (box (void)) + _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 index 328a32d0bd..ca0b6431d9 100644 --- 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 +A -A) +@defform/subs[#:literals (+ - +a -a) (define-objc-class class-id superclass-expr maybe-mixins maybe-protocols @@ -148,9 +148,11 @@ Defines each @racket[protocol-id] to the protocol (a value with FFI type (code:line #:mixins (mixin-expr ...))] [maybe-protocols code:blank (code:line #:protocols (protocol-expr ...))] - [method (mode result-ctype-expr (method-id) body ...+) - (mode result-ctype-expr (arg ...+) body ...+)] - [mode + - +a -a +A -A] + [method (mode maybe-async result-ctype-expr (method-id) body ...+) + (mode maybe-async result-ctype-expr (arg ...+) body ...+)] + [mode + - +a -a] + [maybe-async code:blank + (code:line #:async-apply async-apply-expr)] [arg (code:line method-id [ctype-expr arg-id])])]{ Defines @racket[class-id] as a new, registered Objective-C class (of @@ -167,17 +169,15 @@ 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[-], @racket[-a], or @racket[-A]) to be called on instances, +@racket[mode] is @racket[-] or @racket[-a]) to be called on instances, or it adds a method to the meta-class (when @racket[mode] is -@racket[+], @racket[+a], or @racket[+A]) to be called on the class itself. All +@racket[+] 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. +An optional @racket[#:async-apply] specification determines how +the method works when called from a foreign thread in the +same way as for @racket[_cprocedure]. If a @racket[method] is declared with a single @racket[method-id] and no arguments, then @racket[method-id] must not end with