ffi/unsafe/objc: add support for blocks

Also add some functions for manipualting classes and objects.

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

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}

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)

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)