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