source: project/release/4/objc/trunk/objc-support.scm @ 17867

Last change on this file since 17867 was 17867, checked in by Jim Ursetto, 11 years ago

objc: compiles now

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