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