source: project/release/3/objc/trunk/objc-class-proxies.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: 6.4 KB
Line 
1(use srfi-69 objc-class-proxies-bin)
2
3;;; Common code for class proxies
4
5(define *class-proxies* (make-hash-table))
6(define (lookup-class-proxy ptr)
7  (hash-table-ref/default *class-proxies* ptr #f))
8(define (register-class-proxy ptr proxy)
9  (hash-table-set! *class-proxies* ptr proxy)
10  proxy)
11(define (objc:pointer->class ptr)
12  (and ptr
13       (or (lookup-class-proxy ptr)
14           (register-class-proxy ptr (make-class-proxy ptr)))))
15
16
17;;; For basic implementation
18
19;; IVARS is a list of the instance variables in this class (not in any superclasses), and
20;; is only set for classes with a scheme implementation.
21;; OBJC? is #t if this class is pure Objective C, and #f if implemented in Scheme.
22(define-record objc:class ptr ivars objc?)
23(define-record objc:ivar name type offset function) ;; function: #:slot, #:outlet, #:wrapper, #:ivar;
24                                                    ;; used for ID only
25(define-record-printer (objc:ivar x port)
26  (fprintf port "#<objc:ivar ~a ~a ~a>"
27           (objc:ivar-name x)
28           (objc:ivar-type x)
29           (objc:ivar-function x)))
30(define (objc:ivar->raw x)
31  (make-objc:raw-ivar (objc:ivar-name x)
32                      (objc:ivar-type x)
33                      (objc:ivar-offset x)))
34
35(define (make-class-proxy ptr)
36  (let* ((proxy (make-objc:class ptr '() #t))
37         (super (objc:class-super-class proxy)))  ;; Implicitly instantiate superclass proxy.
38    (if super
39        (objc:class-objc?-set! proxy
40          (objc:class-objc? super)))          ;; Scheme class in hierarchy taints this one.
41    proxy))
42
43;; If TYPES is a string, it's treated as n one-character encoded types.  Otherwise, pass a
44;; list of encoded type strings.
45(define (objc:add-convenience-method! klass method-name types c-func)
46  (let ((typelist (if (string? types)
47                      (string-chop types 1)
48                      types)))
49    (add-method-definition (objc:class->pointer klass)
50                           (string->selector method-name)
51                           (apply conc typelist)
52                           (make-imp-closure typelist c-func
53                                             (objc:class->pointer klass)))))
54
55;; Find ivar NAME, traversing the class hierarchy upward from class C.
56(define (objc:class-ivar-lookup c name)
57  (cond ((not c) #f)
58        ((assoc name (objc:class-ivars c)) => cdr)
59        (else
60         (objc:class-ivar-lookup (objc:class-super-class c) name))))
61
62;; Return all ivars known by the class proxies in the class hierarchy,
63;; which will typically be ivars declared in Scheme.
64(define objc:class-all-ivars
65  (letrec ((all-ivars (lambda (c)
66                        (if (not c)
67                            '()
68                            (cons (objc:class-ivars c)
69                                  (all-ivars (objc:class-super-class c)))))))
70    (lambda (c)
71      (flatten (all-ivars c)))))
72
73(define (objc:ivar-ref obj name)
74  (let* ((ptr  (objc:instance-ptr obj))
75         (ivar (find-ivar ptr name)))
76    (if ivar
77        (let ((scheme-ivar (objc:class-ivar-lookup (objc:class-of obj) name))
78              (ivar-ptr (pointer-offset ptr (Ivar-ivar_offset ivar))))
79         
80          (if scheme-ivar
81              (case (objc:ivar-function scheme-ivar)
82                ((slot:)   (gc-root-ref ivar-ptr))
83                ((wrapper:) (scheme-object-wrapper-ref ivar-ptr))
84                (else (objc:ref->scheme-object ivar-ptr (Ivar-ivar_type ivar))))
85              (objc:ref->scheme-object ivar-ptr (Ivar-ivar_type ivar)))) ;; default (no scheme ivar)
86        (error 'ivar-ref "no such instance variable" name))))
87
88;; Same as scheme-object->ref, but maintain reference counts: if type is ID,
89;; release any old value and retain the new value.  Used in ivar-set!.
90(define (objc:scheme-object->ref/cnt val type ptr)
91  (if (equal? type objc:ID)
92      (let ((old (pointer-ptr-ref ptr 0)))
93        (objc:scheme-object->ref val type ptr)   ;; write id into ptr
94        (let ((new (pointer-ptr-ref ptr 0)))
95          (objc-retain new)
96          (if old (objc-release old))))
97       
98      (objc:scheme-object->ref val type ptr)))
99
100(define (objc:ivar-set! obj name val)
101  (let* ((ptr (objc:instance-ptr obj))
102         (ivar (find-ivar ptr name)))
103    (if ivar
104        (let ((scheme-ivar (objc:class-ivar-lookup (objc:class-of obj) name))
105              (ivar-ptr (pointer-offset ptr (Ivar-ivar_offset ivar)))
106              (type (Ivar-ivar_type ivar)))
107          (if scheme-ivar
108              (case (objc:ivar-function scheme-ivar)
109                ((slot:)   (gc-root-set! ivar-ptr val))
110                ((wrapper:) (scheme-object-wrapper-set! ivar-ptr val))
111                ((outlet:) (objc:scheme-object->ref val objc:ID ivar-ptr))
112                (else (objc:scheme-object->ref/cnt val type ivar-ptr)))
113              (objc:scheme-object->ref val type ivar-ptr))
114          (void))
115        (error 'ivar-set! "no such instance variable" name))))
116
117(define objc:ivar-ref (getter-with-setter objc:ivar-ref objc:ivar-set!))
118
119;;; Deallocation
120
121;; Note: dealloc-scheme is added to every class with scheme implementation, because
122;; the class proxy contains only instance variables specific to that particular class.
123;; So, each call up the chain will free instance variables declared in that class.
124;; An alternative would be to create a function which conses together all instance
125;; variables up the hierarchy, and run this function once, in a first generation
126;; scheme subclass, against this list.  (objc:class-all-ivars would work for this.)
127(define (dealloc-scheme self klass)
128    (for-each (lambda (x)
129                (let* ((x (cdr x))   ;; objc:class-ivars is an alist -- wrap this?
130                       (ivar (find-ivar self (objc:ivar-name x))))
131                  (if ivar
132                      (let ((ivar-ptr (pointer-offset self (Ivar-ivar_offset ivar))))
133                        (if (equal? objc:ID (objc:ivar-type x))
134                            (case (objc:ivar-function x)
135                              ((slot:)   (gc-root-delete! ivar-ptr))
136                              ((wrapper:) (scheme-object-wrapper-delete! ivar-ptr))
137                              ((outlet:) 'noop)
138                              (else  ;; ivar: ?
139                               (let ((id (pointer-ptr-ref ivar-ptr 0)))
140                                 (if id (objc-release id)))))))
141                      (warning (conc "dealloc_scheme: " klass
142                                     " proxy has ivar " x " but ObjC class does not")))))
143              (objc:class-ivars klass)))
144
145
Note: See TracBrowser for help on using the repository browser.