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

;;; class operations

(include "alignment.scm")
(declare (emit-external-prototypes-first))

;;; Registering a new class.

#>!

struct objc_class* register_class(char *name, struct objc_class* super_class) {
  struct objc_class *root_class, *new_class, *meta_class;
                                                                               
  // Find the root class 
  root_class = super_class; 
  while (root_class->super_class != nil)
      root_class = root_class->super_class; 
  
  // Allocate space for the class and its meta class 
  new_class  = calloc (2, sizeof(struct objc_class));
  meta_class = &new_class[1];
  
  // setup class 
  new_class->isa      = meta_class; 
  new_class->info     = CLS_CLASS; 
  meta_class->info    = CLS_META; 
  
  // Create a copy of the class name. 
  // For efficiency, we have the metaclass and the class itself 
  // share this copy of the name, but this is not a requirement
  // imposed by the runtime. 
  // 
  new_class->name = malloc (strlen (name) + 1); 
  strcpy ((char*)new_class->name, name);
  meta_class->name = new_class->name; 
  
  // Allocate empty method lists 

  new_class->methodLists  = malloc (sizeof (struct objc_method_list *));
  meta_class->methodLists = malloc (sizeof (struct objc_method_list *));
  /* Bugfix from PyObjC -- method lists must be terminated by -1 on OS X.
     Without this critical fix, class_addMethods will crash at some point. */
  new_class->methodLists[0] = meta_class->methodLists[0] = (struct objc_method_list *)-1;

  // Connect the class definition to the class hierarchy. 
  // First, connect the class to the superclass 
  // Then connect the metaclass to the metaclass of the superclass 
  // Then connect the metaclass of the metaclass to 
  //              the metaclass of the root class 
  new_class->super_class  = super_class; 
  meta_class->super_class = super_class->isa; 
  meta_class->isa         = (void *)root_class->isa; 

  // Set up instance variables.
  new_class->ivars  = NULL;
  meta_class->ivars = NULL;
  new_class->instance_size  = new_class->super_class->instance_size;
  meta_class->instance_size = meta_class->super_class->instance_size;

  // Note: it may be that the instance_size must be known at registration time,
  // so we would need all ivars available already.  Hopefully, it is not
  // required until alloc, because we update it later.

  meta_class->protocols = new_class->protocols = NULL;
  
  // Finally, register the class with the runtime. 
  objc_addClass (new_class);
  
  return new_class;
}
                                                                               
<#

;; Example: (objc:register-class "TypeTest2" TypeTest)
;; or       (objc:register-class "TypeTest2" (objc:string->class "TypeTest"))
(define (objc:register-class class-name superclass)
    (if (string-to-class class-name)
        (error 'objc:register-class "class already exists" class-name))

    (objc:pointer->class (or (register-class class-name
                                             (objc:class->pointer superclass))
                         (error 'objc:register-class "error during class registration"))))


;;; Creating a class' instance variables.

#>!

struct objc_ivar_list* allocate_ivar_list(int len) {
  /* This may allocate one struct objc_ivar too many. */
  return malloc(sizeof(struct objc_ivar_list) + len * sizeof(struct objc_ivar));
}

int ivar_base_offset(struct objc_class* c) {
  return c->super_class->instance_size;
}

void set_class_ivar(struct objc_ivar_list *ivars, int i, char *name, char *type, int offset) {
  struct objc_ivar *ivar = ivars->ivar_list + i;
  ivar->ivar_name = strdup(name);
  ivar->ivar_type = strdup(type);
  ivar->ivar_offset = offset;
//  printf("set ivar #%d %s type %s at offset %d\n", i, name, type, offset);
}
<#

(define-record-type objc:raw-ivar
  (make-objc:raw-ivar name type offset)
  objc:raw-ivar?
  (name objc:raw-ivar-name objc:raw-ivar-name-set!)
  (type objc:raw-ivar-type objc:raw-ivar-type-set!)
  (offset objc:raw-ivar-offset objc:raw-ivar-offset-set!))

(define-record-printer (objc:raw-ivar x p)
  (fprintf p "#<raw-ivar: ~a ~s at ~a>"
           (objc:raw-ivar-name x)
           (objc:raw-ivar-type x)
           (objc:raw-ivar-offset x)))

;; Example: add variables INT jimmy and DBL cammy to MyClass.  The "offset"
;; and "function" fields are ignored.

;; (objc:set-ivars! MyClass (list (make-objc:raw-ivar "jimmy" objc:INT 0 #f)
;;                                (make-objc:raw-ivar "cammy" objc:DBL 0 #f)))

;; Warning: all old instance variables in MyClass will be removed first.
;; Also, we don't check for conflicts with superclass instance variables,
;; although we should.

(define (objc:set-ivars! class ivars)
  (define (align-offset o type)
    (let* ((a (objc:alignof-type type))
           (modulus (fxmod o a)))
      (fx+ o (if (fx= modulus 0)
                 modulus
                 (fx- a modulus)))))
  (define (set-all-ivars ivar-list ivars base)
    (let loop ((i 0) (ivars ivars) (offset base))
      (if (null? ivars)
          offset
          (let* ((type   (objc:raw-ivar-type (car ivars)))
                 (offset (align-offset offset type)))
            (set-class-ivar ivar-list i
                            (objc:raw-ivar-name (car ivars))
                            type
                            offset)
            (loop (fx+ i 1)
                  (cdr ivars)
                  (fx+ offset (objc:sizeof-type type)))) )))

  (let* ((class-ptr (objc:class->pointer class))
         (num-ivars (length ivars))
         (base (ivar-base-offset class-ptr))
         (ivar-list (allocate-ivar-list num-ivars))
         (instance-size (set-all-ivars ivar-list ivars base)))

    (Ivar-list-ivar_count-set! ivar-list num-ivars)
    (Class-instance_size-set! class-ptr instance-size)
    (Class-ivars-set! class-ptr ivar-list)))


;;; Class instance variable list.

(define (objc:class-ivar-list class)
  (define ivar-list-ref
    (foreign-lambda* c-pointer (((pointer "struct objc_ivar_list") ivars) (int i))
                     "return(&ivars->ivar_list[i]);"))

  (let* ((c (objc:class->pointer class))
         (ivar-list (Class-ivars c))
         (num-ivars (Ivar-list-ivar_count ivar-list)))
         
    (let loop ((i 0))
      (if (fx>= i num-ivars)
          '()
          (let ((ivar (ivar-list-ref ivar-list i)))
            (cons (make-objc:raw-ivar (Ivar-ivar_name ivar)
                                      (Ivar-ivar_type ivar)
                                      (Ivar-ivar_offset ivar))
                  (loop (fx+ i 1))))))))

;;; Class methods

#>!

/* IMP (the signature of func) is typedef id (*IMP)(id, SEL, ...); */

void add_method_definition(struct objc_class *c, void *sel, char *type, void (*func)()) {
  struct objc_method_list *method;
  /* Note: PyObjC seems to allocate an extra objc_method (i.e. "2 * ..." ). */
  size_t size = sizeof (struct objc_method_list) + 1 * sizeof (struct objc_method);

  method = malloc (size);
  method->method_count = 1;
  method->obsolete = NULL;
  method->method_list[0].method_name  = sel;
  method->method_list[0].method_types = strdup(type);
  method->method_list[0].method_imp   = (IMP)func;

  class_addMethods (c, method);
  /* You can remove these methods by passing the same objc_method_list pointer
     to class_removeMethods. */
}  

struct objc_method* find_superclass_method(struct objc_class *c, void *sel) {
  Method m;
  int class_method = c->info & CLS_META;  /* Metaclass indicates we want a class method. */
 
  while ((c = c->super_class)) {
    m = class_method ? class_getClassMethod(c, sel)
                     : class_getInstanceMethod(c, sel);
    if (m) return m;
  }                     
  return NULL;
}

<#

;(define-external (scheme_print (integer i) (scheme-object o)) void
;  (printf "index ~a object ~s\n" i o))

;; These callbacks are used by the FFI method proxy to convert between Scheme and Objective C.
(define-external (ref_to_scheme_object (c-pointer ptr) (c-string type)) scheme-object
  (objc:ref->scheme-object ptr type))
(define-external (scheme_object_to_ref (scheme-object obj) (c-string type) (c-pointer buf)) c-pointer
  (objc:scheme-object->ref obj type buf))

;;;; FFI method proxy C implementation

#>

#include <ffi.h>

struct closure_userdata {
  void *proc_gc_root;
  char *retType;
  char **argTypes;
  int argc;
};                         

/* We now use precomputed argument signature data passed through closure_userdata,
  rather than NSMethodSignature calls.  It seems the signature obtained from
  methodSignatureForSelector: sometimes pulls the wrong (superclass?) signature,
  but we NEED our signature since our class methods use #, not @ as self.
  A class passed into @ screws up our retain count. */

static void objc_method_ffi_stub(ffi_cif* cif __attribute__((__unused__)), void* resp,
                                 void** args, void* _userdata) {
  int i, argc;                                                    
  id self = *(id *)args[0];
  SEL sel = *(SEL *)args[1];
  C_word obj;
  C_word *objs;
  C_word *argument_gc_roots[1];
  C_word proc;
  struct closure_userdata *userdata = _userdata;
  const char *type;

  argc = userdata->argc;
  objs = alloca(argc * sizeof(C_word));
  
  for (i = 0; i < argc; i++) {
    type = userdata->argTypes[i];
    obj = ref_to_scheme_object(args[i], (char *)type);
    objs[i] = obj;  /* It seems we cannot safely C_save here. */
    argument_gc_roots[0] = &objs[i];
    C_gc_protect(argument_gc_roots, 1);  /* Protect objs[] from major GC during the callback. */
  }

  proc = CHICKEN_gc_root_ref(userdata->proc_gc_root);

  // C_callback_adjust_stack_limits(objs);  // Probably a noop, as we already
                                            // called thru define-external.

  for (i = 0 ; i < argc; i++)
    C_save(objs[i]);
  C_gc_unprotect(argc);  /* Assumes no other C_gc_protects interceded. */
  
  obj = C_callback(proc, argc);

  type = userdata->retType;

  scheme_object_to_ref(obj, (char *)type, resp);

  /* Hack for PPC: types < sizeof(int) are returned as int types. */
  switch (*type) {
    case _C_CHR:  *(         int *)resp = *(          char *)resp; break;
    case _C_SHT:  *(         int *)resp = *(         short *)resp; break;
    case _C_UCHR: *(unsigned int *)resp = *(unsigned  char *)resp; break;
    case _C_USHT: *(unsigned int *)resp = *(unsigned short *)resp; break;
  }    
         
}  

<#

#>

/* Preconstructed FFI types for NSPoint, NSSize, NSRange and NSRect. */
static ffi_type* nspoint_type_elements[] = { &ffi_type_float, &ffi_type_float, NULL };
static ffi_type*  nssize_type_elements[] = { &ffi_type_float, &ffi_type_float, NULL };
static ffi_type* nsrange_type_elements[] = { &ffi_type_uint, &ffi_type_uint, NULL };

static ffi_type ffi_type_nspoint = { 0, 0, FFI_TYPE_STRUCT, nspoint_type_elements };
static ffi_type ffi_type_nssize =  { 0, 0, FFI_TYPE_STRUCT, nssize_type_elements };
static ffi_type ffi_type_nsrange = { 0, 0, FFI_TYPE_STRUCT, nsrange_type_elements };

static ffi_type*  nsrect_type_elements[] = { &ffi_type_nspoint, &ffi_type_nssize, NULL };
static ffi_type ffi_type_nsrect =  { 0, 0, FFI_TYPE_STRUCT, nsrect_type_elements };

<#

#>!

/* We implement limited FFI structure-passing support by comparing the type signature
   against supported structures, and returning the corresponding preconstructed FFI type. */
static ffi_type* struct_to_ffi_type (const char* argtype) {
  if (strcmp(argtype, @encode(NSRect)) == 0)
    return &ffi_type_nsrect;
  else if (strcmp(argtype, @encode(NSPoint)) == 0)
    return &ffi_type_nspoint;
  else if (strcmp(argtype, @encode(NSSize)) == 0)
    return &ffi_type_nssize;
  else if (strcmp(argtype, @encode(NSRange)) == 0)
    return &ffi_type_nsrange;
  return NULL;                                                           
}                                                           

/* From PyObjC. */
static ffi_type* signature_to_ffi_type(const char* argtype)
{
  switch (*argtype) {
  case _C_VOID: return &ffi_type_void;
  case _C_ID: return &ffi_type_pointer;
  case _C_CLASS: return &ffi_type_pointer;
  case _C_SEL: return &ffi_type_pointer;
  case _C_CHR: return &ffi_type_schar;
#ifdef _C_BOOL
  case _C_BOOL: return &ffi_type_sint;
#endif  
  case _C_UCHR: return &ffi_type_uchar;
  case _C_SHT: return &ffi_type_sshort;
  case _C_USHT: return &ffi_type_ushort;
  case _C_INT: return &ffi_type_sint;
  case _C_UINT: return &ffi_type_uint;

   /* The next two defintions are incorrect, but the correct definitions
    * don't work (e.g. give testsuite failures). We should be fine
    * as long as sizeof(long) == sizeof(int)  -- PyObjC comment
    */
  case _C_LNG: return &ffi_type_sint;  /* ffi_type_slong */
  case _C_ULNG: return &ffi_type_uint;  /* ffi_type_ulong */
  case _C_LNGLNG: return &ffi_type_sint64;
  case _C_ULNGLNG: return &ffi_type_uint64;
  case _C_FLT: return &ffi_type_float;
  case _C_DBL: return &ffi_type_double;
  case _C_CHARPTR: return &ffi_type_pointer;
  case _C_PTR: return &ffi_type_pointer;

  case _C_IN: case _C_OUT: case _C_INOUT: case _C_CONST:
    return signature_to_ffi_type(argtype+1);
  /* structs only partially supported */
  case _C_STRUCT_B: 
    return struct_to_ffi_type(argtype);
#if 0
  /* unsupported */
  case _C_ARY_B: 
    return array_to_ffi_type(argtype);
#endif
  default:
    return NULL;
  }
}

static ffi_type* signature_to_ffi_return_type(const char* argtype) {
  switch (*argtype) {
  case _C_CHR: case _C_SHT:
    return &ffi_type_sint;
  case _C_UCHR: case _C_USHT:
    return &ffi_type_uint;
#ifdef _C_BOOL
  case _C_BOOL: return &ffi_type_sint;
#endif  
  default:
    return signature_to_ffi_type(argtype);
  }
}

#define OBJC_FFI_OK            0
#define OBJC_FFI_BAD_CIF       2

/* C_c_string does not return a NULL terminated string.  This function
   does so, returning a new string allocated with malloc that must be
   freed by the caller. */
static char *C_c_string0(C_word obj) {
  unsigned int len; char *str;
  C_i_foreign_string_argumentp(obj);
  len = C_header_size(obj);
  str = (char *)C_malloc(len + 1);
  strncpy(str, C_c_string(obj), len);
  str[len] = '\0';
  return str;
}                                      

/* only returns null on error, does not raise an exception */
/* stores the argument and return types in the closure */
static ffi_closure* make_objc_ffi_closure(C_word types, int n, C_word proc) {
  ffi_status s;
  ffi_cif* cif = NULL;
  ffi_closure* closure = NULL;
  ffi_type** atypes = NULL;
  ffi_type* rt = NULL;
  char *str;
  unsigned int i;
  struct closure_userdata *userdata = NULL;

  userdata = malloc(sizeof(*userdata));
  userdata->argc = 0; userdata->proc_gc_root = NULL; userdata->retType = NULL;

  str = C_c_string0(C_u_i_car(types));
  rt = signature_to_ffi_return_type(str);
  if (rt == NULL) goto cleanup;
  userdata->retType = str;  /* C_c_string0 duplicates the string for us */
  types = C_u_i_cdr(types);
  n--;

  atypes = malloc(n * sizeof(ffi_type*));
  userdata->argTypes = malloc(n * sizeof(userdata->argTypes[0]));

  for (i = 0; i < n; i++, types = C_u_i_cdr(types)) {
    str = C_c_string0(C_u_i_car(types));
    atypes[i] = signature_to_ffi_type(str);
    if (atypes[i] == NULL) goto cleanup;
    userdata->argTypes[i] = str;  /* str is dup'd for us by C_c_string0 */
    ++userdata->argc;
  }
  
  cif = malloc(sizeof(ffi_cif));
  
  s = ffi_prep_cif(cif, FFI_DEFAULT_ABI, n, rt, atypes);

  if(s != FFI_OK) goto cleanup;

  closure = malloc(sizeof(*closure));
  userdata->proc_gc_root = CHICKEN_new_gc_root();
  CHICKEN_gc_root_set(userdata->proc_gc_root, proc);  /* Scheme callback closure */

  s = ffi_prep_closure(closure, cif, objc_method_ffi_stub, userdata);

  if (s!=FFI_OK) goto cleanup;
  
  return closure;

cleanup:
    if (userdata) {
       if (userdata->proc_gc_root)
          CHICKEN_delete_gc_root(userdata->proc_gc_root);
       free(userdata->retType);
       for (i = 0; i < userdata->argc; i++)
           free(userdata->argTypes[i]);
       free(userdata);
    }
    free(closure);              
    free(cif);
    free(atypes);
    return NULL;
}                                          

/* A near-exact copy of make_objc_ffi_closure, with userdata passed as a parameter.  We could change
   make_objc_ffi_closure to use this, but some code would be duplicated anyway. */
static ffi_closure* make_imp_closure(C_word types, void *func, void *userdata) {
  ffi_status s;
  ffi_cif* cif = NULL;
  ffi_closure* closure = NULL;
  ffi_type** atypes = NULL;
  ffi_type* rt = NULL;
  char *str;
  unsigned int i;

  int n = C_unfix(C_i_length(types));
  
  str = C_c_string0(C_u_i_car(types));
  rt = signature_to_ffi_return_type(str);
  if (rt == NULL) goto cleanup;
  types = C_u_i_cdr(types);
  n--;

  atypes = malloc(n * sizeof(ffi_type*));

  for (i = 0; i < n; i++, types = C_u_i_cdr(types)) {
    str = C_c_string0(C_u_i_car(types));
    atypes[i] = signature_to_ffi_type(str);
    if (atypes[i] == NULL) goto cleanup;
  }
  
  cif = malloc(sizeof(ffi_cif));

  s = ffi_prep_cif(cif, FFI_DEFAULT_ABI, n, rt, atypes);

  if(s != FFI_OK) goto cleanup;

  closure = malloc(sizeof(*closure));

  s = ffi_prep_closure(closure, cif, func, userdata);

  if (s!=FFI_OK) goto cleanup;

  return closure;

cleanup:
    free(closure);              
    free(cif);
    free(atypes);
    return NULL;
}                                          
    
<#


;;;; Method creation

(define-foreign-record-type (Method "struct objc_method")
  (c-pointer method_name Method-method_name Method-method_name-set!)  ;; actually a SEL
  (c-string method_types Method-method_types Method-method_types-set!)  ;; The way we use this, it could be a c-pointer.
  (c-pointer method_imp Method-method_imp Method-method_imp-set!))

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

(define (make-method-proxy typelist proc)
  (make-objc-ffi-closure typelist (length typelist) proc))

;; Todo: remove existing method (or error out if method exists); however,
;;       the new method will override without removing the old.
;; Todo: we only raise a generic exception when make-method-proxy fails
(define (objc:add-class-method class method-name types proc)
  (objc:add-method (objc:class-meta-class class)
                   method-name types proc))

;; To add a class method, we pass the meta-class.    find-superclass-method also
;; knows to look for a class method if we pass it a meta-class.
(define (objc:add-method class method-name types proc)
  (with-autorelease-pool (lambda ()
    (let* ((class-ptr   (objc:class->pointer class))
           (type-string (apply string-append types))
           (selector    (string->new-selector method-name)))
      (add-method-definition class-ptr
                             selector
                             type-string
                             (or (make-method-proxy types proc)
                                 (error 'objc:add-method "failed to create method proxy")))

      ;; experimental tainting feature: treat class as non-pure ObjC as soon as
      ;; a Scheme method is added.  Forces maybe-safe calls to be safe.
      (when (objc:class-objc? class)
        (objc:class-objc?-set! class #f)
        (warning (conc "pure ObjC class " class " tainted with scheme method " method-name)))

      ;; Add supermethod (if found) by prepending "classname:super:" to our selector.
      ;; Required because NSInvocation cannot call a supermethod under OS X.
      (let ((super-method (find-superclass-method class-ptr selector)))
        (if super-method
            (add-method-definition class-ptr
                                   (string->new-selector (string-append
                                                          (Class-name class-ptr) ":"
                                                          "super:" method-name))
                                   (Method-method_types super-method)
                                   (Method-method_imp   super-method))))))))