source: project/release/4/objc/trunk/objc-support.scm @ 14899

;;; objc-support

(include "array.scm")
(include "convert.scm")

#>
#import <Foundation/Foundation.h>
#import <objc/objc-runtime.h>
#import <objc/objc-class.h>
#import "objc-runtime.h"
#define DEBUG_BAD_RETAIN_COUNT
#define IGNORE_UINT_MAX_RETAIN_COUNT

static NSAutoreleasePool *default_pool = NULL;

<#

#>:
default_pool = [[NSAutoreleasePool alloc] init];
<#

#>!
___declare(default_renaming, "")

/* Safe because we may override in a Scheme class.  Note
   that this principle may apply elsewhere. */
___safe static const char *objc_description(void *s) 
{
  return [[(NSObject *)s description] UTF8String];
  /* Warning: return value is autoreleased. */
}

static void *make_nsstring(char *s)
{
  return [[NSString alloc] initWithUTF8String: s];
}

static ___bool is_nsstring(void *o)
{
  NSObject *ob = (NSObject *)o;
  return [ob isKindOfClass: [NSString class]];
}

static const char *nsstring_to_string(NSString *o) {
  return [o UTF8String];                                                    
}                                                    

/* safe because release may send a dealloc message, which calls back into
   dealloc-scheme when using class proxies */
___safe static void objc_release(NSObject *o)
{
#ifdef DEBUG_BAD_RETAIN_COUNT
  int count = [o retainCount];
  /* We have to assume a retain count of -1 is legal, as the Apple runtime
     uses it to denote immutable or cached objects.  But note, sometimes -1 can
     indicate a problem, for non-immutable objects. */
  if (count < 1
#  ifdef IGNORE_UINT_MAX_RETAIN_COUNT
            && count != -1
#  endif
            ) {
    fprintf(stderr, "*** Warning: trying to release retain count %d!\n", count);
    fprintf(stderr, "(class %s, instance @ %p)\n", [o class]->name, o);
  } else
#endif
  {
//  fprintf(stderr, "objc_release: released %s @ %p, retain count was %d\n",
//          [o class]->name, o, [o retainCount]);                 
    [o release];
  }
}

static void objc_retain(NSObject *o) { [o retain]; }
static int objc_retain_count(NSObject *o) { return [o retainCount]; }
static void retain_and_autorelease(NSObject *o) { [[o retain] autorelease]; }

static struct objc_class *class_of(NSObject *o) {
  return [o class];
}
<#

(define string-to-class (foreign-lambda c-pointer "objc_lookUpClass" c-string))

;; Class is a struct objc_class*.

(define-foreign-record (Class "struct objc_class")
  (c-pointer isa)
  (c-pointer super_class)
  (c-string name)
  (long version)
  (long info)
  (long instance_size)
  (c-pointer ivars)
  ((struct objc_method_list) methodLists)   ;; xxx actually a double pointer, but should access via
                                            ;; class_nextMethodList anyway.
  ((struct objc_cache) cache)
  ((struct objc_protocol_list) protocols))

;;; #<objc:class> records

(define-record-type objc:class
  (make-objc:class ptr)
  objc:class?
  (ptr objc:class-ptr objc:class-ptr-set!))

(define (objc:class-ivars x) '())  ;; Dummy implementations; defined in the class proxies.
(define (objc:class-objc? x) #f)

;; We can't use objc-description right now, since we risk encountering a class
;; not derived from NSObject, yet imported by objc:import-classes-at-toplevel!.
(define (objc:class-name x)
  (let ((ptr (objc:class-ptr x)))
    (if ptr
        (Class-name (objc:class-ptr x))
        "<NULL>")))

(define (objc:class-method-list x)
  (objc_class_method_list (objc:class-ptr x)))
(define (objc:class-class-method-list x)
  (objc:class-method-list (objc:class-meta-class x)))

(define (objc:class-meta-class c)
  (objc:pointer->class (Class-isa (objc:class->pointer c))))
(define (objc:class-super-class c)
  (objc:pointer->class (Class-super_class (objc:class->pointer c))))

(define-record-printer (objc:class x port)
  (fprintf port "#<objc-class ~a>" (objc:class-name x)))

(define (objc:nsstring s)
  (let* ((raw-str (make-nsstring s))
         (obj (objc:pointer->instance raw-str)))
    (objc-release raw-str)  ;; since alloc donates a reference (hopefully)
    obj))
(define (objc:nsstring->string s)
  (with-autorelease-pool (lambda ()
    (let ((s-ptr (objc:instance->pointer s)))
      (if (is-nsstring s-ptr)
          (nsstring-to-string s-ptr)
          (error 'objc:nsstring->string "not an NSString" s))))))

(define (objc:string->class s)
  (objc:pointer->class (or (string-to-class s)
                           (error 'objc:string->class "failed class lookup" s))))
(define objc:pointer->class make-objc:class)
(define objc:class->pointer objc:class-ptr)

;; WARNING: foreign types must be defined -before- they are referred to.  If defined after,
;; they will be accepted as valid types, but any transformations will be silently ignored.
;; In other words, the original object will be passed straight through as a c-pointer.

;; Convert foreign input arguments specified as type objc:class
;; into struct objc_class *.  Argument is checked for correct type
;; via the objc:class-ptr call, not by any other means.
(define-foreign-type objc-class
  (pointer "struct objc_class")
  (lambda (x) (objc:class-ptr x)))

;;; #<objc:instance> records

(define-record-type objc:instance
  (make-objc:instance ptr)
  objc:instance?
  (ptr objc:instance-ptr objc:instance-ptr-set!))

(define-foreign-type objc-instance
  (pointer "struct objc_object")
  (lambda (x) (objc:instance-ptr x)))

(define-record-printer (objc:instance ptr p)
  (let ((ptr (objc:instance-ptr ptr)))
    (if (is-nsstring ptr)
        (fprintf p "@~s" (objc-description ptr))
        (fprintf p "#<objc-instance ~a>" (objc-description ptr))) ) ) 

(define (objc:class-or-instance-ptr x)
  (if (objc:instance? x)
      (objc:instance-ptr x)   ;; could use (##sys#slot x 1) or (block-ref x 1)
      (objc:class-ptr x)))

;; "Polymorphic" foreign type
(define-foreign-type objc-instance-or-class
  (pointer "struct objc_object")
  objc:class-or-instance-ptr)

;; Note: releasing an uninitialized object can crash some classes.  We can't detect this
;; case; PyObjC can and will deliberately leak the object as there is no good solution.
(define (objc:pointer->instance o)
  (and o      ;; Check for #f -- I suppose we could check null pointer as well.
       (begin #+debug (print "objc:pointer->instance: retained " o)
              (objc-retain o)
              (set-finalizer! o objc-release)  ;; note finalizer is on pointer
              (make-objc:instance o))))

(define (objc:instance->pointer o)
  (and o (objc:instance-ptr o)))   ;; Allow bare #f to represent 'nil'.

(define (objc:class-of o)
  (objc:pointer->class
   (class-of (objc:class-or-instance-ptr o))))

;;; Return a list of all classes known to the Objective C runtime.

;; int objc_getClassList(Class *buffer, int len): Writes up to LEN objc_class pointers
;; into BUFFER.  Storage for BUFFER can be provided by (make-vector len).
(define objc:_get_class_list! (foreign-lambda int "objc_getClassList" scheme-pointer int))

(define (objc:number-of-classes)  ;; internal
  (objc:_get_class_list! (null-pointer) 0))

(define (objc:get-class-list)
  (let* ((num (objc:number-of-classes))
         (array (make-vector num)))
    (objc:_get_class_list! array num)
    (ptr-array-map->list (lambda (p) (objc:pointer->class p))
                         array)))
    
;;; instance variables

(define-foreign-record-type (Ivar-list "struct objc_ivar_list")
  (int ivar_count Ivar-list-ivar_count Ivar-list-ivar_count-set!)
  ((const c-pointer) ivar_list  Ivar-list-ivar_list Ivar-list-ivar_list-set!))

(define-foreign-record-type (Ivar "struct objc_ivar")
  (c-string ivar_name Ivar-ivar_name Ivar-ivar_name-set!)
  (c-string ivar_type Ivar-ivar_type Ivar-ivar_type-set!)
  (int ivar_offset Ivar-ivar_offset Ivar-ivar_offset-set!))

;; object_getInstanceVariable returns the variable value, not a pointer to the value
;; as the documentation claims.  Instead, we obtain the Ivar struct with
;; class_getInstanceVariable, and add ivar_offset to the object's pointer.

#>!
/* From PyObjC -- traverse all superclasses to find Ivar structure. */
static struct objc_ivar* find_ivar(NSObject* base, char* name)
{
    Class cur = GETISA((id)base);
    Ivar ivar;

    while (cur != NULL) {
        ivar = class_getInstanceVariable(cur, name);
        if (ivar != NULL) {
            return ivar;
        }
        cur = cur->super_class;
    }
    return NULL;
}
<#

;;;; ivar-ref

(define (objc:ivar-ref obj name)
  (let* ((ptr  (objc:instance-ptr obj))
         (ivar (find-ivar ptr name)))
    (if ivar
        (objc:ref->scheme-object (pointer-offset ptr (Ivar-ivar_offset ivar))
                                 (Ivar-ivar_type ivar))
        (error 'ivar-ref "no such instance variable" name))))

;;;; ivar-set!

;; Note: if type == ID, we may need to (optionally?) retain this object and autorelease the
;; old one.  Now that memory management is automatic this needs to be revisited.
(define (objc:ivar-set! obj name val)
  (let* ((ptr (objc:instance-ptr obj))
         (ivar (find-ivar ptr name)))
    (if ivar
        (begin (objc:scheme-object->ref val
                                        (Ivar-ivar_type ivar)
                                        (pointer-offset ptr (Ivar-ivar_offset ivar)))
               (void))
        (error 'ivar-set! "no such instance variable" name))))

;; Comply with SRFI-17.  With @ read syntax, this allows (set! @hi 3) to be an
;; alias for (objc:ivar-set! self "hi" 3).
(define objc:ivar-ref (getter-with-setter objc:ivar-ref objc:ivar-set!))

;;; Classes

(include "classes.scm")

;;;; Class import as symbols

;; Disabled, because when using class proxies this will instantiate every one.
(define objc:classes (objc:get-class-list))   ;; or objc-classes, hyphen?

;; Define all Objective C classes as symbols at toplevel.  We don't
;; ensure derivation from NSObject, so this is not completely safe.
;; For this reason, we do not send a message to obtain the class name.
;; XXX May not be safe at all now, if we use class proxies.
(define (objc:import-classes-at-toplevel!)
  (set! objc:classes (objc:get-class-list))
  (for-each (lambda (x)
              (global-set! (string->symbol
                            (Class-name (objc:class-ptr x)))
                           x))
            objc:classes))

;;;; class methods

(define objc_class_method_list
  (foreign-primitive scheme-object ((c-pointer c)) #<<EOF

  void *iterator = NULL;
  struct objc_method_list *mlist;
  int i;
  C_word lst = C_SCHEME_END_OF_LIST;
  C_word *p1, *p2, *s1, *s2;
  int len1;
  int len2;
  Method method;
  
  while((mlist = class_nextMethodList (c, &iterator))) {
      method = mlist->method_list;
      
      for(i=0 ; i < mlist->method_count ; i++){
          p1 = C_alloc(C_SIZEOF_PAIR);
          p2 = C_alloc(C_SIZEOF_PAIR);
          len1 = strlen((char *)method->method_name);
          len2 = strlen(method->method_types);
          s1 = C_alloc(C_SIZEOF_STRING(len1));
          s2 = C_alloc(C_SIZEOF_STRING(len2));

          lst = C_pair(&p1, C_pair(&p2, C_string(&s1, len1, (char *)method->method_name),
                                        C_string(&s2, len2, method->method_types)),
                            lst);
          method++;
      }
  }

  return(lst);

EOF
))



;;; invoker

#>!
static ___bool invoke(NSInvocation *inv) {
   NS_DURING                                       
   [inv invoke];

   NS_HANDLER
   NSLog([localException name]);
   NSLog([localException reason]);
   return 0;

   NS_ENDHANDLER
   return 1;
}                                       

___safe static ___bool invoke_safe(NSInvocation *inv) {
   return invoke(inv);
}                                       

/* Pass class to obtain class method selector, object for instance method selector. */
static NSMethodSignature *selector_to_signature(NSObject *o, void *sel) {
  return [o methodSignatureForSelector: (SEL)sel];
}
/* Obtain instance method selector whether passed class or object. */
static NSMethodSignature *instance_selector_to_signature(NSObject *o, void *sel) {
  return [[o class] instanceMethodSignatureForSelector: (SEL)sel];
}         

static const char *method_return_type(NSMethodSignature *sig) {
  return [sig methodReturnType];
}

static int method_return_length(NSMethodSignature *sig) {
  return [sig methodReturnLength];
}

static int method_argument_count(NSMethodSignature *sig) {
  return [sig numberOfArguments];
}

static const char *method_argument_type(NSMethodSignature *sig, int i) {
  return [sig getArgumentTypeAtIndex: i];
}

static void set_method_argument(NSInvocation *inv, int i, void *buf) {
  [inv setArgument: buf atIndex: i];
}

static NSInvocation *create_invocation(NSMethodSignature *sig, NSObject *target, void *sel) {
  NSInvocation *inv;
  inv = [NSInvocation invocationWithMethodSignature:sig];
  [inv setTarget:target];
  [inv setSelector:sel];

  /* Because the GC loses track of the target once it is placed into an NSInvocation,
     we must retain+autorelease it to ensure it stays alive.  This applies to the
     arguments as well, but they are retain+autoreleased in objc:instance->ref. */
  [[target retain] autorelease];
  return inv;
}                                                                                        

/* Invocation via NSInvocation fails, as it tries to retain the return value (the pool). */
static NSObject *new_autorelease_pool(void) {
  NSAutoreleasePool *pool = [[NSAutoreleasePool alloc] init];
  return pool;                    
}

static int retain_count(NSObject *o) {
  return [o retainCount];
}

<#

(define (make-autorelease-pool) (make-objc:instance (new-autorelease-pool))) ;; internal
(define (with-autorelease-pool thunk)
  (let ((pool #f))
    (dynamic-wind (lambda () (set! pool (new-autorelease-pool)))
                  thunk
                  (lambda () (objc-release pool)))))

(define string->selector (foreign-lambda c-pointer "sel_getUid" c-string))

(define-foreign-type NSInvocation* (pointer "NSInvocation"))
(define get-return-value!
  (foreign-lambda* void ((NSInvocation* inv) (scheme-pointer buf))
                   "[inv getReturnValue: buf];"))

;; On Mac OS X (PPC) char and short result types return full ints.
(define sizeof-result-type
  (let ((sizeof-int (objc:sizeof-type "i")))
    (lambda (t)
      (fxmax sizeof-int (objc:sizeof-type t)))))

;; selector-allocates?: #t if this selector allocates or otherwise donates a reference.
;; (Warning: "donation" might differ from "allocation".)
(define selector-allocates?
  (let ((allocating-selectors (map (cut string->selector <>)
                                   (list "alloc" "allocWithZone:" "copy" "copyWithZone:"
                                         "mutableCopy:" "mutableCopyWithZone:"))))
    (lambda (sel)
      (member sel allocating-selectors))))

;; NSInvocation cannot send to super.  We are forced to create method proxies called
;; classname:super:selector for any found super methods.
;; NSInvocation retains and autoreleases its return value if it's an ID, so
;; we surround it with an autorelease pool.
;; Note: an invocation of "autorelease" will not work as expected.  The receiver will
;; be autoreleased immediately after the NSInvocation finishes.
;; Note: We must retain the target and all instance arguments--see create-invocation.
(define objc:optimize-callbacks (make-parameter #t))

(define (objc:invoker safe? target method-name . args)
  (let* ((safe?  (if (and (eq? safe? 'maybe)
                          (objc:optimize-callbacks))  ;; specify at compile time instead?
                     (not (objc:class-objc? (if (objc:instance? target)
                                                (objc:class-of target)
                                                target)))
                     safe?))  ;; safe? could still be 'maybe here, which is boolean #t
         (target-ptr (objc:class-or-instance-ptr target))
         (sel    (string->selector method-name))
         (pool   (new-autorelease-pool))
         (err    (lambda args (objc-release pool) (apply error args)))
         (sig    (or (selector-to-signature target-ptr sel)
                     (err 'objc:invoker "method not found" method-name)))
         (inv    (create-invocation sig target-ptr sel))  ;; GC may forget target-ptr after this
         (nargs  (method-argument-count sig)))

    ;; Set all arguments.  (This loop is used purely for its side-effects.)
    (let loop! ((i 2) (args args))
      (if (or (fx= i nargs) (null? args))
          (if (and (fx= i nargs) (null? args))  ;; arg count matches passed args,
              #t                                ;; so we're done.
              (err 'objc:invoker (conc "bad argument count - received " (fx- i 2)
                                         " but expected " (fx- nargs 2))))

          (let* ((type (method-argument-type sig i))
                 (buf  (make-byte-vector (sizeof-result-type type))))
            (set-method-argument inv i 
                                 (objc:scheme-object->ref (car args) type
                                                          (make-locative buf)))
            (loop! (fx+ i 1) (cdr args)))))

    (unless ((if safe? invoke-safe invoke) inv)
      (err 'objc:invoker "exception during invocation"))
    
    (let ((len (method-return-length sig)))
      (let ((result (if (zero? len)
                        (void)    ;; void return would throw an exception in get-return-value!.
                        (let ((buf (make-byte-vector len)))
                          (get-return-value! inv buf)
                          (objc:ref->scheme-object (make-locative buf)
                                                   (method-return-type sig))))))
        (if (selector-allocates? sel)
            (objc-release (objc:instance-ptr result)))
        (objc-release pool)
        result ))))

;; Whether we warn or error out if a class is already defined.
(define objc:allow-class-redefinition (make-parameter #t))