source: project/release/4/objc/trunk/objc-support.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: 17.5 KB
Line 
1;;; objc-support
2
3(include "array.scm")
4(include "convert.scm")
5
6#>
7#import <Foundation/Foundation.h>
8#import <objc/objc-runtime.h>
9#import <objc/objc-class.h>
10#import "objc-runtime.h"
11#define DEBUG_BAD_RETAIN_COUNT
12#define IGNORE_UINT_MAX_RETAIN_COUNT
13
14static NSAutoreleasePool *default_pool = NULL;
15
16<#
17
18#>:
19default_pool = [[NSAutoreleasePool alloc] init];
20<#
21
22#>!
23___declare(default_renaming, "")
24
25/* Safe because we may override in a Scheme class.  Note
26   that this principle may apply elsewhere. */
27___safe static const char *objc_description(void *s) 
28{
29  return [[(NSObject *)s description] UTF8String];
30  /* Warning: return value is autoreleased. */
31}
32
33static void *make_nsstring(char *s)
34{
35  return [[NSString alloc] initWithUTF8String: s];
36}
37
38static ___bool is_nsstring(void *o)
39{
40  NSObject *ob = (NSObject *)o;
41  return [ob isKindOfClass: [NSString class]];
42}
43
44static const char *nsstring_to_string(NSString *o) {
45  return [o UTF8String];                                                   
46}                                                   
47
48/* safe because release may send a dealloc message, which calls back into
49   dealloc-scheme when using class proxies */
50___safe static void objc_release(NSObject *o)
51{
52#ifdef DEBUG_BAD_RETAIN_COUNT
53  int count = [o retainCount];
54  /* We have to assume a retain count of -1 is legal, as the Apple runtime
55     uses it to denote immutable or cached objects.  But note, sometimes -1 can
56     indicate a problem, for non-immutable objects. */
57  if (count < 1
58#  ifdef IGNORE_UINT_MAX_RETAIN_COUNT
59            && count != -1
60#  endif
61            ) {
62    fprintf(stderr, "*** Warning: trying to release retain count %d!\n", count);
63    fprintf(stderr, "(class %s, instance @ %p)\n", [o class]->name, o);
64  } else
65#endif
66  {
67//  fprintf(stderr, "objc_release: released %s @ %p, retain count was %d\n",
68//          [o class]->name, o, [o retainCount]);                 
69    [o release];
70  }
71}
72
73static void objc_retain(NSObject *o) { [o retain]; }
74static int objc_retain_count(NSObject *o) { return [o retainCount]; }
75static void retain_and_autorelease(NSObject *o) { [[o retain] autorelease]; }
76
77static struct objc_class *class_of(NSObject *o) {
78  return [o class];
79}
80<#
81
82(define string-to-class (foreign-lambda c-pointer "objc_lookUpClass" c-string))
83
84;; Class is a struct objc_class*.
85
86(define-foreign-record (Class "struct objc_class")
87  (c-pointer isa)
88  (c-pointer super_class)
89  (c-string name)
90  (long version)
91  (long info)
92  (long instance_size)
93  (c-pointer ivars)
94  ((struct objc_method_list) methodLists)   ;; xxx actually a double pointer, but should access via
95                                            ;; class_nextMethodList anyway.
96  ((struct objc_cache) cache)
97  ((struct objc_protocol_list) protocols))
98
99;;; #<objc:class> records
100
101(define-record-type objc:class
102  (make-objc:class ptr)
103  objc:class?
104  (ptr objc:class-ptr objc:class-ptr-set!))
105
106(define (objc:class-ivars x) '())  ;; Dummy implementations; defined in the class proxies.
107(define (objc:class-objc? x) #f)
108
109;; We can't use objc-description right now, since we risk encountering a class
110;; not derived from NSObject, yet imported by objc:import-classes-at-toplevel!.
111(define (objc:class-name x)
112  (let ((ptr (objc:class-ptr x)))
113    (if ptr
114        (Class-name (objc:class-ptr x))
115        "<NULL>")))
116
117(define (objc:class-method-list x)
118  (objc_class_method_list (objc:class-ptr x)))
119(define (objc:class-class-method-list x)
120  (objc:class-method-list (objc:class-meta-class x)))
121
122(define (objc:class-meta-class c)
123  (objc:pointer->class (Class-isa (objc:class->pointer c))))
124(define (objc:class-super-class c)
125  (objc:pointer->class (Class-super_class (objc:class->pointer c))))
126
127(define-record-printer (objc:class x port)
128  (fprintf port "#<objc-class ~a>" (objc:class-name x)))
129
130(define (objc:nsstring s)
131  (let* ((raw-str (make-nsstring s))
132         (obj (objc:pointer->instance raw-str)))
133    (objc-release raw-str)  ;; since alloc donates a reference (hopefully)
134    obj))
135(define (objc:nsstring->string s)
136  (with-autorelease-pool (lambda ()
137    (let ((s-ptr (objc:instance->pointer s)))
138      (if (is-nsstring s-ptr)
139          (nsstring-to-string s-ptr)
140          (error 'objc:nsstring->string "not an NSString" s))))))
141
142(define (objc:string->class s)
143  (objc:pointer->class (or (string-to-class s)
144                           (error 'objc:string->class "failed class lookup" s))))
145(define objc:pointer->class make-objc:class)
146(define objc:class->pointer objc:class-ptr)
147
148;; WARNING: foreign types must be defined -before- they are referred to.  If defined after,
149;; they will be accepted as valid types, but any transformations will be silently ignored.
150;; In other words, the original object will be passed straight through as a c-pointer.
151
152;; Convert foreign input arguments specified as type objc:class
153;; into struct objc_class *.  Argument is checked for correct type
154;; via the objc:class-ptr call, not by any other means.
155(define-foreign-type objc-class
156  (pointer "struct objc_class")
157  (lambda (x) (objc:class-ptr x)))
158
159;;; #<objc:instance> records
160
161(define-record-type objc:instance
162  (make-objc:instance ptr)
163  objc:instance?
164  (ptr objc:instance-ptr objc:instance-ptr-set!))
165
166(define-foreign-type objc-instance
167  (pointer "struct objc_object")
168  (lambda (x) (objc:instance-ptr x)))
169
170(define-record-printer (objc:instance ptr p)
171  (let ((ptr (objc:instance-ptr ptr)))
172    (if (is-nsstring ptr)
173        (fprintf p "@~s" (objc-description ptr))
174        (fprintf p "#<objc-instance ~a>" (objc-description ptr))) ) ) 
175
176(define (objc:class-or-instance-ptr x)
177  (if (objc:instance? x)
178      (objc:instance-ptr x)   ;; could use (##sys#slot x 1) or (block-ref x 1)
179      (objc:class-ptr x)))
180
181;; "Polymorphic" foreign type
182(define-foreign-type objc-instance-or-class
183  (pointer "struct objc_object")
184  objc:class-or-instance-ptr)
185
186;; Note: releasing an uninitialized object can crash some classes.  We can't detect this
187;; case; PyObjC can and will deliberately leak the object as there is no good solution.
188(define (objc:pointer->instance o)
189  (and o      ;; Check for #f -- I suppose we could check null pointer as well.
190       (begin #+debug (print "objc:pointer->instance: retained " o)
191              (objc-retain o)
192              (set-finalizer! o objc-release)  ;; note finalizer is on pointer
193              (make-objc:instance o))))
194
195(define (objc:instance->pointer o)
196  (and o (objc:instance-ptr o)))   ;; Allow bare #f to represent 'nil'.
197
198(define (objc:class-of o)
199  (objc:pointer->class
200   (class-of (objc:class-or-instance-ptr o))))
201
202;;; Return a list of all classes known to the Objective C runtime.
203
204;; int objc_getClassList(Class *buffer, int len): Writes up to LEN objc_class pointers
205;; into BUFFER.  Storage for BUFFER can be provided by (make-vector len).
206(define objc:_get_class_list! (foreign-lambda int "objc_getClassList" scheme-pointer int))
207
208(define (objc:number-of-classes)  ;; internal
209  (objc:_get_class_list! (null-pointer) 0))
210
211(define (objc:get-class-list)
212  (let* ((num (objc:number-of-classes))
213         (array (make-vector num)))
214    (objc:_get_class_list! array num)
215    (ptr-array-map->list (lambda (p) (objc:pointer->class p))
216                         array)))
217   
218;;; instance variables
219
220(define-foreign-record-type (Ivar-list "struct objc_ivar_list")
221  (int ivar_count Ivar-list-ivar_count Ivar-list-ivar_count-set!)
222  ((const c-pointer) ivar_list  Ivar-list-ivar_list Ivar-list-ivar_list-set!))
223
224(define-foreign-record-type (Ivar "struct objc_ivar")
225  (c-string ivar_name Ivar-ivar_name Ivar-ivar_name-set!)
226  (c-string ivar_type Ivar-ivar_type Ivar-ivar_type-set!)
227  (int ivar_offset Ivar-ivar_offset Ivar-ivar_offset-set!))
228
229;; object_getInstanceVariable returns the variable value, not a pointer to the value
230;; as the documentation claims.  Instead, we obtain the Ivar struct with
231;; class_getInstanceVariable, and add ivar_offset to the object's pointer.
232
233#>!
234/* From PyObjC -- traverse all superclasses to find Ivar structure. */
235static struct objc_ivar* find_ivar(NSObject* base, char* name)
236{
237    Class cur = GETISA((id)base);
238    Ivar ivar;
239
240    while (cur != NULL) {
241        ivar = class_getInstanceVariable(cur, name);
242        if (ivar != NULL) {
243            return ivar;
244        }
245        cur = cur->super_class;
246    }
247    return NULL;
248}
249<#
250
251;;;; ivar-ref
252
253(define (objc:ivar-ref obj name)
254  (let* ((ptr  (objc:instance-ptr obj))
255         (ivar (find-ivar ptr name)))
256    (if ivar
257        (objc:ref->scheme-object (pointer-offset ptr (Ivar-ivar_offset ivar))
258                                 (Ivar-ivar_type ivar))
259        (error 'ivar-ref "no such instance variable" name))))
260
261;;;; ivar-set!
262
263;; Note: if type == ID, we may need to (optionally?) retain this object and autorelease the
264;; old one.  Now that memory management is automatic this needs to be revisited.
265(define (objc:ivar-set! obj name val)
266  (let* ((ptr (objc:instance-ptr obj))
267         (ivar (find-ivar ptr name)))
268    (if ivar
269        (begin (objc:scheme-object->ref val
270                                        (Ivar-ivar_type ivar)
271                                        (pointer-offset ptr (Ivar-ivar_offset ivar)))
272               (void))
273        (error 'ivar-set! "no such instance variable" name))))
274
275;; Comply with SRFI-17.  With @ read syntax, this allows (set! @hi 3) to be an
276;; alias for (objc:ivar-set! self "hi" 3).
277(define objc:ivar-ref (getter-with-setter objc:ivar-ref objc:ivar-set!))
278
279;;; Classes
280
281(include "classes.scm")
282
283;;;; Class import as symbols
284
285;; Disabled, because when using class proxies this will instantiate every one.
286(define objc:classes (objc:get-class-list))   ;; or objc-classes, hyphen?
287
288;; Define all Objective C classes as symbols at toplevel.  We don't
289;; ensure derivation from NSObject, so this is not completely safe.
290;; For this reason, we do not send a message to obtain the class name.
291;; XXX May not be safe at all now, if we use class proxies.
292(define (objc:import-classes-at-toplevel!)
293  (set! objc:classes (objc:get-class-list))
294  (for-each (lambda (x)
295              (global-set! (string->symbol
296                            (Class-name (objc:class-ptr x)))
297                           x))
298            objc:classes))
299
300;;;; class methods
301
302(define objc_class_method_list
303  (foreign-primitive scheme-object ((c-pointer c)) #<<EOF
304
305  void *iterator = NULL;
306  struct objc_method_list *mlist;
307  int i;
308  C_word lst = C_SCHEME_END_OF_LIST;
309  C_word *p1, *p2, *s1, *s2;
310  int len1;
311  int len2;
312  Method method;
313 
314  while((mlist = class_nextMethodList (c, &iterator))) {
315      method = mlist->method_list;
316     
317      for(i=0 ; i < mlist->method_count ; i++){
318          p1 = C_alloc(C_SIZEOF_PAIR);
319          p2 = C_alloc(C_SIZEOF_PAIR);
320          len1 = strlen((char *)method->method_name);
321          len2 = strlen(method->method_types);
322          s1 = C_alloc(C_SIZEOF_STRING(len1));
323          s2 = C_alloc(C_SIZEOF_STRING(len2));
324
325          lst = C_pair(&p1, C_pair(&p2, C_string(&s1, len1, (char *)method->method_name),
326                                        C_string(&s2, len2, method->method_types)),
327                            lst);
328          method++;
329      }
330  }
331
332  return(lst);
333
334EOF
335))
336
337
338
339;;; invoker
340
341#>!
342static ___bool invoke(NSInvocation *inv) {
343   NS_DURING                                       
344   [inv invoke];
345
346   NS_HANDLER
347   NSLog([localException name]);
348   NSLog([localException reason]);
349   return 0;
350
351   NS_ENDHANDLER
352   return 1;
353}                                       
354
355___safe static ___bool invoke_safe(NSInvocation *inv) {
356   return invoke(inv);
357}                                       
358
359/* Pass class to obtain class method selector, object for instance method selector. */
360static NSMethodSignature *selector_to_signature(NSObject *o, void *sel) {
361  return [o methodSignatureForSelector: (SEL)sel];
362}
363/* Obtain instance method selector whether passed class or object. */
364static NSMethodSignature *instance_selector_to_signature(NSObject *o, void *sel) {
365  return [[o class] instanceMethodSignatureForSelector: (SEL)sel];
366}         
367
368static const char *method_return_type(NSMethodSignature *sig) {
369  return [sig methodReturnType];
370}
371
372static int method_return_length(NSMethodSignature *sig) {
373  return [sig methodReturnLength];
374}
375
376static int method_argument_count(NSMethodSignature *sig) {
377  return [sig numberOfArguments];
378}
379
380static const char *method_argument_type(NSMethodSignature *sig, int i) {
381  return [sig getArgumentTypeAtIndex: i];
382}
383
384static void set_method_argument(NSInvocation *inv, int i, void *buf) {
385  [inv setArgument: buf atIndex: i];
386}
387
388static NSInvocation *create_invocation(NSMethodSignature *sig, NSObject *target, void *sel) {
389  NSInvocation *inv;
390  inv = [NSInvocation invocationWithMethodSignature:sig];
391  [inv setTarget:target];
392  [inv setSelector:sel];
393
394  /* Because the GC loses track of the target once it is placed into an NSInvocation,
395     we must retain+autorelease it to ensure it stays alive.  This applies to the
396     arguments as well, but they are retain+autoreleased in objc:instance->ref. */
397  [[target retain] autorelease];
398  return inv;
399}                                                                                       
400
401/* Invocation via NSInvocation fails, as it tries to retain the return value (the pool). */
402static NSObject *new_autorelease_pool(void) {
403  NSAutoreleasePool *pool = [[NSAutoreleasePool alloc] init];
404  return pool;                   
405}
406
407static int retain_count(NSObject *o) {
408  return [o retainCount];
409}
410
411<#
412
413(define (make-autorelease-pool) (make-objc:instance (new-autorelease-pool))) ;; internal
414(define (with-autorelease-pool thunk)
415  (let ((pool #f))
416    (dynamic-wind (lambda () (set! pool (new-autorelease-pool)))
417                  thunk
418                  (lambda () (objc-release pool)))))
419
420(define string->selector (foreign-lambda c-pointer "sel_getUid" c-string))
421
422(define-foreign-type NSInvocation* (pointer "NSInvocation"))
423(define get-return-value!
424  (foreign-lambda* void ((NSInvocation* inv) (scheme-pointer buf))
425                   "[inv getReturnValue: buf];"))
426
427;; On Mac OS X (PPC) char and short result types return full ints.
428(define sizeof-result-type
429  (let ((sizeof-int (objc:sizeof-type "i")))
430    (lambda (t)
431      (fxmax sizeof-int (objc:sizeof-type t)))))
432
433;; selector-allocates?: #t if this selector allocates or otherwise donates a reference.
434;; (Warning: "donation" might differ from "allocation".)
435(define selector-allocates?
436  (let ((allocating-selectors (map (cut string->selector <>)
437                                   (list "alloc" "allocWithZone:" "copy" "copyWithZone:"
438                                         "mutableCopy:" "mutableCopyWithZone:"))))
439    (lambda (sel)
440      (member sel allocating-selectors))))
441
442;; NSInvocation cannot send to super.  We are forced to create method proxies called
443;; classname:super:selector for any found super methods.
444;; NSInvocation retains and autoreleases its return value if it's an ID, so
445;; we surround it with an autorelease pool.
446;; Note: an invocation of "autorelease" will not work as expected.  The receiver will
447;; be autoreleased immediately after the NSInvocation finishes.
448;; Note: We must retain the target and all instance arguments--see create-invocation.
449(define objc:optimize-callbacks (make-parameter #t))
450
451(define (objc:invoker safe? target method-name . args)
452  (let* ((safe?  (if (and (eq? safe? 'maybe)
453                          (objc:optimize-callbacks))  ;; specify at compile time instead?
454                     (not (objc:class-objc? (if (objc:instance? target)
455                                                (objc:class-of target)
456                                                target)))
457                     safe?))  ;; safe? could still be 'maybe here, which is boolean #t
458         (target-ptr (objc:class-or-instance-ptr target))
459         (sel    (string->selector method-name))
460         (pool   (new-autorelease-pool))
461         (err    (lambda args (objc-release pool) (apply error args)))
462         (sig    (or (selector-to-signature target-ptr sel)
463                     (err 'objc:invoker "method not found" method-name)))
464         (inv    (create-invocation sig target-ptr sel))  ;; GC may forget target-ptr after this
465         (nargs  (method-argument-count sig)))
466
467    ;; Set all arguments.  (This loop is used purely for its side-effects.)
468    (let loop! ((i 2) (args args))
469      (if (or (fx= i nargs) (null? args))
470          (if (and (fx= i nargs) (null? args))  ;; arg count matches passed args,
471              #t                                ;; so we're done.
472              (err 'objc:invoker (conc "bad argument count - received " (fx- i 2)
473                                         " but expected " (fx- nargs 2))))
474
475          (let* ((type (method-argument-type sig i))
476                 (buf  (make-byte-vector (sizeof-result-type type))))
477            (set-method-argument inv i 
478                                 (objc:scheme-object->ref (car args) type
479                                                          (make-locative buf)))
480            (loop! (fx+ i 1) (cdr args)))))
481
482    (unless ((if safe? invoke-safe invoke) inv)
483      (err 'objc:invoker "exception during invocation"))
484   
485    (let ((len (method-return-length sig)))
486      (let ((result (if (zero? len)
487                        (void)    ;; void return would throw an exception in get-return-value!.
488                        (let ((buf (make-byte-vector len)))
489                          (get-return-value! inv buf)
490                          (objc:ref->scheme-object (make-locative buf)
491                                                   (method-return-type sig))))))
492        (if (selector-allocates? sel)
493            (objc-release (objc:instance-ptr result)))
494        (objc-release pool)
495        result ))))
496
497;; Whether we warn or error out if a class is already defined.
498(define objc:allow-class-redefinition (make-parameter #t))
Note: See TracBrowser for help on using the repository browser.