ffi/unsafe/objc: add support for blocks
Also add some functions for manipualting classes and objects.
This commit is contained in:
parent
053aae7b59
commit
24592f78fc
|
@ -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]))
|
||||
|
|
|
@ -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}
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue
Block a user