From 24592f78fc67ca79ed8f0f810a85c7a9ff4e057f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 4 Sep 2015 07:49:46 -0600 Subject: [PATCH] ffi/unsafe/objc: add support for blocks Also add some functions for manipualting classes and objects. --- pkgs/base/info.rkt | 2 +- .../racket-doc/scribblings/foreign/objc.scrbl | 50 +++++++++++++ racket/collects/ffi/unsafe/objc.rkt | 71 ++++++++++++++++++- racket/src/racket/src/schvers.h | 4 +- 4 files changed, 122 insertions(+), 5 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index af45814da3..2f61c6306d 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "6.2.900.13") +(define version "6.2.900.14") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/foreign/objc.scrbl b/pkgs/racket-doc/scribblings/foreign/objc.scrbl index 56a18d406f..6a52571c9d 100644 --- a/pkgs/racket-doc/scribblings/foreign/objc.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/objc.scrbl @@ -269,6 +269,56 @@ Check whether @racket[subcls] is @racket[cls] or a subclass. @history[#:added "6.1.0.5"]} + +@defproc[(objc-get-class [obj _id]) _Class]{ + +Extract the class of @racket[obj]. + +@history[#:added "6.2.900.14"]} + + +@defproc[(objc-set-class! [obj _id] [cls _Class]) void?]{ + +Changes the class of @racket[obj] to @racket[cls]. The object's +existing representation must be compatible with the new class. + +@history[#:added "6.2.900.14"]} + + +@defproc[(objc-get-superclass [cls _Class]) _Class]{ + +Returns the superclass of @racket[cls]. + +@history[#:added "6.2.900.14"]} + + +@defproc[(objc-dispose-class [cls _Class]) void?]{ + +Destroys @racket[cls], which must have no existing instances or +subclasses. + +@history[#:added "6.2.900.14"]} + + +@defproc[(objc-block [function-type? ctype] + [proc procedure?] + [#:keep keep (box/c list?)]) + cpointer?]{ + +Wraps a Racket function @racket[proc] as an Objective-C block. The +procedure must accept an initial pointer argument that is the ``self'' +argument for the block, and that extra argument must be included in +the given @racket[function-type]. + +Extra records that are allocated to implement the block are added to +the list in @racket[keep], which might also be included in +@racket[function-type] through a @racket[#:keep] option to +@racket[_fun]. The pointers registered in @racket[keep] must be +retained as long as the block remains in use. + +@history[#:added "6.2.900.14"]} + + @; ---------------------------------------------------------------------- @section{Raw Runtime Functions} diff --git a/racket/collects/ffi/unsafe/objc.rkt b/racket/collects/ffi/unsafe/objc.rkt index 6eed6ea1a3..5b906398b2 100644 --- a/racket/collects/ffi/unsafe/objc.rkt +++ b/racket/collects/ffi/unsafe/objc.rkt @@ -149,6 +149,13 @@ #f))]) (cast new _objc_class-pointer _Class))) +(define (dispose-class-pair-the-hard-way c-id) + (define c (cast _Class _objc_class-pointer)) + (define meta (cast _pointer _objc_class-pointer)) + (free (objc_class-name c)) + (free (objc_class-isa c)) + (free c)) + (define (add-ivar-the-hard-way class field-name field-name-type) (let* ([class (cast class _Class _objc_class-pointer)] [ivars (or (objc_class-ivars class) @@ -218,6 +225,8 @@ (define-objc objc_allocateClassPair (_fun _Class _string _long -> _Class) #:fail (lambda () #f)) +(define-objc objc_disposeClassPair (_fun _Class -> _void) + #:fail (lambda () #f)) (define-objc objc_registerClassPair (_fun _Class -> _void) #:fail (lambda () #f)) @@ -226,6 +235,8 @@ (define-objc object_getClass (_fun _id -> _Class) #:fail (lambda () #f)) +(define-objc object_setClass (_fun _id _Class -> _void) + #:fail (lambda () #f)) (define-objc class_addMethod/raw (_fun _Class _SEL _fpointer _string -> _BOOL) #:c-id class_addMethod @@ -567,7 +578,8 @@ (provide define-objc-class define-objc-mixin - self super-tell) + self super-tell + objc-dispose-class) (define-for-syntax ((check-id stx what) id) (unless (identifier? id) @@ -674,6 +686,11 @@ (objc_allocateClassPair superclass-id id-str 0) (allocate-class-pair-the-hard-way superclass-id id-str))) +(define (dispose-class-pair c-id) + (if objc_disposeClassPair + (objc_disposeClassPair c-id) + (dispose-class-pair-the-hard-way c-id))) + (define (register-class-pair id) (if objc_registerClassPair (objc_registerClassPair id) @@ -689,6 +706,11 @@ (object_getClass id) (ptr-ref id _Class))) +(define (object-set-class! id c-id) + (if object_setClass + (object_setClass id c-id) + (ptr-set! id _Class c-id))) + (define (layout->string l) (case l [(uint8) "C"] @@ -874,10 +896,16 @@ #'((make-objc_super self super-class)) #'(method/arg ...))])) +(define (objc-dispose-class c) + (dispose-class-pair c)) + ;; -------------------------------------------------- (provide objc-is-a? - objc-subclass?) + objc-subclass? + objc-get-class + objc-set-class! + objc-get-superclass) (define-objc class_getSuperclass (_fun _Class -> _Class)) @@ -890,6 +918,12 @@ (and pc (objc-subclass? pc c))))) +(define (objc-get-class v) (object-get-class v)) +(define (objc-set-class! v c) (object-set-class! v c)) + +(define (objc-get-superclass c) + (class_getSuperclass c)) + ;; -------------------------------------------------- (define-objc class_getInstanceMethod (_fun _Class _SEL -> _Method)) @@ -898,3 +932,36 @@ (set-objc_method-method_imp! (cast meth _Method _objc_method-pointer) (function-ptr imp _IMP))))) + +;; -------------------------------------------------- + +(provide objc-block) + +(define-cstruct _block ([isa _pointer] + [flags _int] + [reserved _int] + [invoke _fpointer] + [descriptor _pointer]) + #:malloc-mode 'atomic-interior) + +(define-cstruct _block-desc ([reserved _ulong] + [size _ulong]) + #:malloc-mode 'atomic-interior) + +(define-objc _NSConcreteGlobalBlock _pointer + #:fail (lambda () #f)) + +(define (objc-block type proc #:keep keep) + (unless _NSConcreteGlobalBlock + (error 'objc-block "unsupported")) + + (define desc + (make-block-desc 0 (ctype-sizeof _block))) + (define blk + (make-block _NSConcreteGlobalBlock + (arithmetic-shift 3 28) + 0 + (cast proc type _fpointer) + desc)) + (set-box! keep (list* blk desc (unbox keep))) + blk) diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 0e9f6a01e0..06e21322b8 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "6.2.900.13" +#define MZSCHEME_VERSION "6.2.900.14" #define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_Y 2 #define MZSCHEME_VERSION_Z 900 -#define MZSCHEME_VERSION_W 13 +#define MZSCHEME_VERSION_W 14 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)