source: project/release/3/objc/trunk/classes.scm @ 9966

Last change on this file since 9966 was 9966, checked in by Kon Lovett, 13 years ago

Using canonical directory structure.

File size: 19.3 KB
Line 
1;;; class operations
2
3(include "alignment.scm")
4(declare (emit-external-prototypes-first))
5
6;;; Registering a new class.
7
8#>!
9
10struct objc_class* register_class(char *name, struct objc_class* super_class) {
11  struct objc_class *root_class, *new_class, *meta_class;
12                                                                               
13  // Find the root class 
14  root_class = super_class;
15  while (root_class->super_class != nil)
16      root_class = root_class->super_class;
17 
18  // Allocate space for the class and its meta class 
19  new_class  = calloc (2, sizeof(struct objc_class));
20  meta_class = &new_class[1];
21 
22  // setup class 
23  new_class->isa      = meta_class;
24  new_class->info     = CLS_CLASS;
25  meta_class->info    = CLS_META;
26 
27  // Create a copy of the class name. 
28  // For efficiency, we have the metaclass and the class itself 
29  // share this copy of the name, but this is not a requirement
30  // imposed by the runtime. 
31  // 
32  new_class->name = malloc (strlen (name) + 1);
33  strcpy ((char*)new_class->name, name);
34  meta_class->name = new_class->name;
35 
36  // Allocate empty method lists 
37
38  new_class->methodLists  = malloc (sizeof (struct objc_method_list *));
39  meta_class->methodLists = malloc (sizeof (struct objc_method_list *));
40  /* Bugfix from PyObjC -- method lists must be terminated by -1 on OS X.
41     Without this critical fix, class_addMethods will crash at some point. */
42  new_class->methodLists[0] = meta_class->methodLists[0] = (struct objc_method_list *)-1;
43
44  // Connect the class definition to the class hierarchy. 
45  // First, connect the class to the superclass 
46  // Then connect the metaclass to the metaclass of the superclass 
47  // Then connect the metaclass of the metaclass to 
48  //              the metaclass of the root class 
49  new_class->super_class  = super_class;
50  meta_class->super_class = super_class->isa;
51  meta_class->isa         = (void *)root_class->isa;
52
53  // Set up instance variables.
54  new_class->ivars  = NULL;
55  meta_class->ivars = NULL;
56  new_class->instance_size  = new_class->super_class->instance_size;
57  meta_class->instance_size = meta_class->super_class->instance_size;
58
59  // Note: it may be that the instance_size must be known at registration time,
60  // so we would need all ivars available already.  Hopefully, it is not
61  // required until alloc, because we update it later.
62
63  meta_class->protocols = new_class->protocols = NULL;
64 
65  // Finally, register the class with the runtime. 
66  objc_addClass (new_class);
67 
68  return new_class;
69}
70                                                                               
71<#
72
73;; Example: (objc:register-class "TypeTest2" TypeTest)
74;; or       (objc:register-class "TypeTest2" (objc:string->class "TypeTest"))
75(define (objc:register-class class-name superclass)
76    (if (string-to-class class-name)
77        (error 'objc:register-class "class already exists" class-name))
78
79    (objc:pointer->class (or (register-class class-name
80                                             (objc:class->pointer superclass))
81                         (error 'objc:register-class "error during class registration"))))
82
83
84;;; Creating a class' instance variables.
85
86#>!
87
88struct objc_ivar_list* allocate_ivar_list(int len) {
89  /* This may allocate one struct objc_ivar too many. */
90  return malloc(sizeof(struct objc_ivar_list) + len * sizeof(struct objc_ivar));
91}
92
93int ivar_base_offset(struct objc_class* c) {
94  return c->super_class->instance_size;
95}
96
97void set_class_ivar(struct objc_ivar_list *ivars, int i, char *name, char *type, int offset) {
98  struct objc_ivar *ivar = ivars->ivar_list + i;
99  ivar->ivar_name = strdup(name);
100  ivar->ivar_type = strdup(type);
101  ivar->ivar_offset = offset;
102//  printf("set ivar #%d %s type %s at offset %d\n", i, name, type, offset);
103}
104<#
105
106(define-record objc:raw-ivar name type offset)
107(define-record-printer (objc:raw-ivar x p)
108  (fprintf p "#<raw-ivar: ~a ~s at ~a>"
109           (objc:raw-ivar-name x)
110           (objc:raw-ivar-type x)
111           (objc:raw-ivar-offset x)))
112
113;; Example: add variables INT jimmy and DBL cammy to MyClass.  The "offset"
114;; and "function" fields are ignored.
115
116;; (objc:set-ivars! MyClass (list (make-objc:raw-ivar "jimmy" objc:INT 0 #f)
117;;                                (make-objc:raw-ivar "cammy" objc:DBL 0 #f)))
118
119;; Warning: all old instance variables in MyClass will be removed first.
120;; Also, we don't check for conflicts with superclass instance variables,
121;; although we should.
122
123(define (objc:set-ivars! class ivars)
124  (define (align-offset o type)
125    (let* ((a (objc:alignof-type type))
126           (modulus (fxmod o a)))
127      (fx+ o (if (fx= modulus 0)
128                 modulus
129                 (fx- a modulus)))))
130  (define (set-all-ivars ivar-list ivars base)
131    (let loop ((i 0) (ivars ivars) (offset base))
132      (if (null? ivars)
133          offset
134          (let* ((type   (objc:raw-ivar-type (car ivars)))
135                 (offset (align-offset offset type)))
136            (set-class-ivar ivar-list i
137                            (objc:raw-ivar-name (car ivars))
138                            type
139                            offset)
140            (loop (fx+ i 1)
141                  (cdr ivars)
142                  (fx+ offset (objc:sizeof-type type)))) )))
143
144  (let* ((class-ptr (objc:class->pointer class))
145         (num-ivars (length ivars))
146         (base (ivar-base-offset class-ptr))
147         (ivar-list (allocate-ivar-list num-ivars))
148         (instance-size (set-all-ivars ivar-list ivars base)))
149
150    (Ivar-list-ivar_count-set! ivar-list num-ivars)
151    (Class-instance_size-set! class-ptr instance-size)
152    (Class-ivars-set! class-ptr ivar-list)))
153
154
155;;; Class instance variable list.
156
157(define (objc:class-ivar-list class)
158  (define ivar-list-ref
159    (foreign-lambda* c-pointer (((pointer "struct objc_ivar_list") ivars) (int i))
160                     "return(&ivars->ivar_list[i]);"))
161
162  (let* ((c (objc:class->pointer class))
163         (ivar-list (Class-ivars c))
164         (num-ivars (Ivar-list-ivar_count ivar-list)))
165         
166    (let loop ((i 0))
167      (if (fx>= i num-ivars)
168          '()
169          (let ((ivar (ivar-list-ref ivar-list i)))
170            (cons (make-objc:raw-ivar (Ivar-ivar_name ivar)
171                                      (Ivar-ivar_type ivar)
172                                      (Ivar-ivar_offset ivar))
173                  (loop (fx+ i 1))))))))
174
175;;; Class methods
176
177#>!
178
179/* IMP (the signature of func) is typedef id (*IMP)(id, SEL, ...); */
180
181void add_method_definition(struct objc_class *c, void *sel, char *type, void (*func)()) {
182  struct objc_method_list *method;
183  /* Note: PyObjC seems to allocate an extra objc_method (i.e. "2 * ..." ). */
184  size_t size = sizeof (struct objc_method_list) + 1 * sizeof (struct objc_method);
185
186  method = malloc (size);
187  method->method_count = 1;
188  method->obsolete = NULL;
189  method->method_list[0].method_name  = sel;
190  method->method_list[0].method_types = strdup(type);
191  method->method_list[0].method_imp   = (IMP)func;
192
193  class_addMethods (c, method);
194  /* You can remove these methods by passing the same objc_method_list pointer
195     to class_removeMethods. */
196} 
197
198struct objc_method* find_superclass_method(struct objc_class *c, void *sel) {
199  Method m;
200  int class_method = c->info & CLS_META;  /* Metaclass indicates we want a class method. */
201 
202  while ((c = c->super_class)) {
203    m = class_method ? class_getClassMethod(c, sel)
204                     : class_getInstanceMethod(c, sel);
205    if (m) return m;
206  }                     
207  return NULL;
208}
209
210<#
211
212;(define-external (scheme_print (integer i) (scheme-object o)) void
213;  (printf "index ~a object ~s\n" i o))
214
215;; These callbacks are used by the FFI method proxy to convert between Scheme and Objective C.
216(define-external (ref_to_scheme_object (c-pointer ptr) (c-string type)) scheme-object
217  (objc:ref->scheme-object ptr type))
218(define-external (scheme_object_to_ref (scheme-object obj) (c-string type) (c-pointer buf)) c-pointer
219  (objc:scheme-object->ref obj type buf))
220
221;;;; FFI method proxy C implementation
222
223#>
224
225#include <ffi.h>
226
227struct closure_userdata {
228  void *proc_gc_root;
229  char *retType;
230  char **argTypes;
231  int argc;
232};                         
233
234/* We now use precomputed argument signature data passed through closure_userdata,
235  rather than NSMethodSignature calls.  It seems the signature obtained from
236  methodSignatureForSelector: sometimes pulls the wrong (superclass?) signature,
237  but we NEED our signature since our class methods use #, not @ as self.
238  A class passed into @ screws up our retain count. */
239
240static void objc_method_ffi_stub(ffi_cif* cif __attribute__((__unused__)), void* resp,
241                                 void** args, void* _userdata) {
242  int i, argc;                                                   
243  id self = *(id *)args[0];
244  SEL sel = *(SEL *)args[1];
245  C_word obj;
246  C_word *objs;
247  C_word *argument_gc_roots[1];
248  C_word proc;
249  struct closure_userdata *userdata = _userdata;
250  const char *type;
251
252  argc = userdata->argc;
253  objs = alloca(argc * sizeof(C_word));
254 
255  for (i = 0; i < argc; i++) {
256    type = userdata->argTypes[i];
257    obj = ref_to_scheme_object(args[i], (char *)type);
258    objs[i] = obj;  /* It seems we cannot safely C_save here. */
259    argument_gc_roots[0] = &objs[i];
260    C_gc_protect(argument_gc_roots, 1);  /* Protect objs[] from major GC during the callback. */
261  }
262
263  proc = CHICKEN_gc_root_ref(userdata->proc_gc_root);
264
265  // C_callback_adjust_stack_limits(objs);  // Probably a noop, as we already
266                                            // called thru define-external.
267
268  for (i = 0 ; i < argc; i++)
269    C_save(objs[i]);
270  C_gc_unprotect(argc);  /* Assumes no other C_gc_protects interceded. */
271 
272  obj = C_callback(proc, argc);
273
274  type = userdata->retType;
275
276  scheme_object_to_ref(obj, (char *)type, resp);
277
278  /* Hack for PPC: types < sizeof(int) are returned as int types. */
279  switch (*type) {
280    case _C_CHR:  *(         int *)resp = *(          char *)resp; break;
281    case _C_SHT:  *(         int *)resp = *(         short *)resp; break;
282    case _C_UCHR: *(unsigned int *)resp = *(unsigned  char *)resp; break;
283    case _C_USHT: *(unsigned int *)resp = *(unsigned short *)resp; break;
284  }   
285         
286} 
287
288<#
289
290#>
291
292/* Preconstructed FFI types for NSPoint, NSSize, NSRange and NSRect. */
293static ffi_type* nspoint_type_elements[] = { &ffi_type_float, &ffi_type_float, NULL };
294static ffi_type*  nssize_type_elements[] = { &ffi_type_float, &ffi_type_float, NULL };
295static ffi_type* nsrange_type_elements[] = { &ffi_type_uint, &ffi_type_uint, NULL };
296
297static ffi_type ffi_type_nspoint = { 0, 0, FFI_TYPE_STRUCT, nspoint_type_elements };
298static ffi_type ffi_type_nssize =  { 0, 0, FFI_TYPE_STRUCT, nssize_type_elements };
299static ffi_type ffi_type_nsrange = { 0, 0, FFI_TYPE_STRUCT, nsrange_type_elements };
300
301static ffi_type*  nsrect_type_elements[] = { &ffi_type_nspoint, &ffi_type_nssize, NULL };
302static ffi_type ffi_type_nsrect =  { 0, 0, FFI_TYPE_STRUCT, nsrect_type_elements };
303
304<#
305
306#>!
307
308/* We implement limited FFI structure-passing support by comparing the type signature
309   against supported structures, and returning the corresponding preconstructed FFI type. */
310static ffi_type* struct_to_ffi_type (const char* argtype) {
311  if (strcmp(argtype, @encode(NSRect)) == 0)
312    return &ffi_type_nsrect;
313  else if (strcmp(argtype, @encode(NSPoint)) == 0)
314    return &ffi_type_nspoint;
315  else if (strcmp(argtype, @encode(NSSize)) == 0)
316    return &ffi_type_nssize;
317  else if (strcmp(argtype, @encode(NSRange)) == 0)
318    return &ffi_type_nsrange;
319  return NULL;                                                           
320}                                                           
321
322/* From PyObjC. */
323static ffi_type* signature_to_ffi_type(const char* argtype)
324{
325  switch (*argtype) {
326  case _C_VOID: return &ffi_type_void;
327  case _C_ID: return &ffi_type_pointer;
328  case _C_CLASS: return &ffi_type_pointer;
329  case _C_SEL: return &ffi_type_pointer;
330  case _C_CHR: return &ffi_type_schar;
331#ifdef _C_BOOL
332  case _C_BOOL: return &ffi_type_sint;
333#endif 
334  case _C_UCHR: return &ffi_type_uchar;
335  case _C_SHT: return &ffi_type_sshort;
336  case _C_USHT: return &ffi_type_ushort;
337  case _C_INT: return &ffi_type_sint;
338  case _C_UINT: return &ffi_type_uint;
339
340   /* The next two defintions are incorrect, but the correct definitions
341    * don't work (e.g. give testsuite failures). We should be fine
342    * as long as sizeof(long) == sizeof(int)  -- PyObjC comment
343    */
344  case _C_LNG: return &ffi_type_sint;  /* ffi_type_slong */
345  case _C_ULNG: return &ffi_type_uint;  /* ffi_type_ulong */
346  case _C_LNGLNG: return &ffi_type_sint64;
347  case _C_ULNGLNG: return &ffi_type_uint64;
348  case _C_FLT: return &ffi_type_float;
349  case _C_DBL: return &ffi_type_double;
350  case _C_CHARPTR: return &ffi_type_pointer;
351  case _C_PTR: return &ffi_type_pointer;
352
353  case _C_IN: case _C_OUT: case _C_INOUT: case _C_CONST:
354    return signature_to_ffi_type(argtype+1);
355  /* structs only partially supported */
356  case _C_STRUCT_B: 
357    return struct_to_ffi_type(argtype);
358#if 0
359  /* unsupported */
360  case _C_ARY_B: 
361    return array_to_ffi_type(argtype);
362#endif
363  default:
364    return NULL;
365  }
366}
367
368static ffi_type* signature_to_ffi_return_type(const char* argtype) {
369  switch (*argtype) {
370  case _C_CHR: case _C_SHT:
371    return &ffi_type_sint;
372  case _C_UCHR: case _C_USHT:
373    return &ffi_type_uint;
374#ifdef _C_BOOL
375  case _C_BOOL: return &ffi_type_sint;
376#endif 
377  default:
378    return signature_to_ffi_type(argtype);
379  }
380}
381
382#define OBJC_FFI_OK            0
383#define OBJC_FFI_BAD_CIF       2
384
385/* C_c_string does not return a NULL terminated string.  This function
386   does so, returning a new string allocated with malloc that must be
387   freed by the caller. */
388static char *C_c_string0(C_word obj) {
389  unsigned int len; char *str;
390  C_i_foreign_string_argumentp(obj);
391  len = C_header_size(obj);
392  str = (char *)C_malloc(len + 1);
393  strncpy(str, C_c_string(obj), len);
394  str[len] = '\0';
395  return str;
396}                                     
397
398/* only returns null on error, does not raise an exception */
399/* stores the argument and return types in the closure */
400static ffi_closure* make_objc_ffi_closure(C_word types, int n, C_word proc) {
401  ffi_status s;
402  ffi_cif* cif = NULL;
403  ffi_closure* closure = NULL;
404  ffi_type** atypes = NULL;
405  ffi_type* rt = NULL;
406  char *str;
407  unsigned int i;
408  struct closure_userdata *userdata = NULL;
409
410  userdata = malloc(sizeof(*userdata));
411  userdata->argc = 0; userdata->proc_gc_root = NULL; userdata->retType = NULL;
412
413  str = C_c_string0(C_u_i_car(types));
414  rt = signature_to_ffi_return_type(str);
415  if (rt == NULL) goto cleanup;
416  userdata->retType = str;  /* C_c_string0 duplicates the string for us */
417  types = C_u_i_cdr(types);
418  n--;
419
420  atypes = malloc(n * sizeof(ffi_type*));
421  userdata->argTypes = malloc(n * sizeof(userdata->argTypes[0]));
422
423  for (i = 0; i < n; i++, types = C_u_i_cdr(types)) {
424    str = C_c_string0(C_u_i_car(types));
425    atypes[i] = signature_to_ffi_type(str);
426    if (atypes[i] == NULL) goto cleanup;
427    userdata->argTypes[i] = str;  /* str is dup'd for us by C_c_string0 */
428    ++userdata->argc;
429  }
430 
431  cif = malloc(sizeof(ffi_cif));
432 
433  s = ffi_prep_cif(cif, FFI_DEFAULT_ABI, n, rt, atypes);
434
435  if(s != FFI_OK) goto cleanup;
436
437  closure = malloc(sizeof(*closure));
438  userdata->proc_gc_root = CHICKEN_new_gc_root();
439  CHICKEN_gc_root_set(userdata->proc_gc_root, proc);  /* Scheme callback closure */
440
441  s = ffi_prep_closure(closure, cif, objc_method_ffi_stub, userdata);
442
443  if (s!=FFI_OK) goto cleanup;
444 
445  return closure;
446
447cleanup:
448    if (userdata) {
449       if (userdata->proc_gc_root)
450          CHICKEN_delete_gc_root(userdata->proc_gc_root);
451       free(userdata->retType);
452       for (i = 0; i < userdata->argc; i++)
453           free(userdata->argTypes[i]);
454       free(userdata);
455    }
456    free(closure);             
457    free(cif);
458    free(atypes);
459    return NULL;
460}                                         
461
462/* A near-exact copy of make_objc_ffi_closure, with userdata passed as a parameter.  We could change
463   make_objc_ffi_closure to use this, but some code would be duplicated anyway. */
464static ffi_closure* make_imp_closure(C_word types, void *func, void *userdata) {
465  ffi_status s;
466  ffi_cif* cif = NULL;
467  ffi_closure* closure = NULL;
468  ffi_type** atypes = NULL;
469  ffi_type* rt = NULL;
470  char *str;
471  unsigned int i;
472
473  int n = C_unfix(C_i_length(types));
474 
475  str = C_c_string0(C_u_i_car(types));
476  rt = signature_to_ffi_return_type(str);
477  if (rt == NULL) goto cleanup;
478  types = C_u_i_cdr(types);
479  n--;
480
481  atypes = malloc(n * sizeof(ffi_type*));
482
483  for (i = 0; i < n; i++, types = C_u_i_cdr(types)) {
484    str = C_c_string0(C_u_i_car(types));
485    atypes[i] = signature_to_ffi_type(str);
486    if (atypes[i] == NULL) goto cleanup;
487  }
488 
489  cif = malloc(sizeof(ffi_cif));
490
491  s = ffi_prep_cif(cif, FFI_DEFAULT_ABI, n, rt, atypes);
492
493  if(s != FFI_OK) goto cleanup;
494
495  closure = malloc(sizeof(*closure));
496
497  s = ffi_prep_closure(closure, cif, func, userdata);
498
499  if (s!=FFI_OK) goto cleanup;
500
501  return closure;
502
503cleanup:
504    free(closure);             
505    free(cif);
506    free(atypes);
507    return NULL;
508}                                         
509   
510<#
511
512
513;;;; Method creation
514
515(define-foreign-record (Method "struct objc_method")
516  (c-pointer method_name)  ;; actually a SEL
517  (c-string method_types)  ;; The way we use this, it could be a c-pointer.
518  (c-pointer method_imp))
519 
520(define string->new-selector (foreign-lambda c-pointer "sel_registerName" c-string))
521
522(define (make-method-proxy typelist proc)
523  (make-objc-ffi-closure typelist (length typelist) proc))
524
525;; Todo: remove existing method (or error out if method exists); however,
526;;       the new method will override without removing the old.
527;; Todo: we only raise a generic exception when make-method-proxy fails
528(define (objc:add-class-method class method-name types proc)
529  (objc:add-method (objc:class-meta-class class)
530                   method-name types proc))
531
532;; To add a class method, we pass the meta-class.    find-superclass-method also
533;; knows to look for a class method if we pass it a meta-class.
534(define (objc:add-method class method-name types proc)
535  (with-autorelease-pool (lambda ()
536    (let* ((class-ptr   (objc:class->pointer class))
537           (type-string (apply string-append types))
538           (selector    (string->new-selector method-name)))
539      (add-method-definition class-ptr
540                             selector
541                             type-string
542                             (or (make-method-proxy types proc)
543                                 (error 'objc:add-method "failed to create method proxy")))
544
545      ;; experimental tainting feature: treat class as non-pure ObjC as soon as
546      ;; a Scheme method is added.  Forces maybe-safe calls to be safe.
547      (when (objc:class-objc? class)
548        (objc:class-objc?-set! class #f)
549        (warning (conc "pure ObjC class " class " tainted with scheme method " method-name)))
550
551      ;; Add supermethod (if found) by prepending "classname:super:" to our selector.
552      ;; Required because NSInvocation cannot call a supermethod under OS X.
553      (let ((super-method (find-superclass-method class-ptr selector)))
554        (if super-method
555            (add-method-definition class-ptr
556                                   (string->new-selector (string-append
557                                                          (Class-name class-ptr) ":"
558                                                          "super:" method-name))
559                                   (Method-method_types super-method)
560                                   (Method-method_imp   super-method))))))))
Note: See TracBrowser for help on using the repository browser.