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

Last change on this file since 14899 was 14899, checked in by Alex Shinn, 12 years ago

initial conversion, not yet working

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