source: trunk/source/objc-bridge/objc-clos.lisp @ 12455

Last change on this file since 12455 was 12455, checked in by gb, 10 years ago

In (SETF CLASS-DIRECT-SLOTS) :BEFORE method on OBJC:OBJC-CLASS:
check that #_class_addIvar succeeds to avoid obscure errors that
occur if it doesn't (it's not yet implemented in Cocotron.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 37.9 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2003-2004 Clozure Associates and contributors.
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16;;;
17;;; TO DO
18;;;  - Both method creation and invocation should be faster and cons less
19;;;  - Resolve messages with repeated keywords
20;;;    (rename them to :range1:range2 or don't use &key in GFs and methods)
21;;;  - How to integrate SEND-SUPER with CALL-NEXT-METHOD?
22;;;  - Variable arity ObjC methods
23;;;  - Pass-by-ref structures need to keep track of IN, OUT, IN/OUT info
24;;;  - Need to canonicalize and retain every returned :ID
25;;;  - Support :BEFORE, :AFTER and :AROUND for ObjC methods
26;;;  - User-defined ObjC methods via DEFMETHOD (or DEFINE-OBJ-METHOD)
27;;;  - Need to fully handle init keywords and ObjC init messages
28
29;;; Package and module stuff
30
31(in-package "CCL")
32
33(eval-when (:compile-toplevel :execute)
34  #+(or apple-objc cocotron-objc)
35  (use-interface-dir :cocoa)
36  #+gnu-objc
37  (use-interface-dir :gnustep))
38
39(require "SEQUENCE-UTILS")
40;;; We need OBJC-FOREIGN-ARG-TYPE from the bridge to process ivar types
41(require "BRIDGE")
42
43
44(defparameter *objc-import-private-ivars* t "When true, the CLASS-DIRECT-SLOTS of imported ObjC classes will contain slot definitions for instance variables whose name starts with an underscore.  Note that this may exacerbate compatibility problems.")
45
46
47
48
49
50;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51;;;;                                 Testing                                ;;;;
52;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
53
54;;; Enable some debugging output.
55(defparameter *objc-clos-debug* nil)
56
57
58
59
60;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
61;;;;                     OBJC Foreign Object Domain                         ;;;;
62;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
63
64(defconstant objc-type-flags (byte 3 20))
65(defconstant objc-type-index (byte 20 0))
66(defconstant objc-flag-instance 0)
67(defconstant objc-flag-class 1)
68(defconstant objc-flag-metaclass 2)
69
70(defvar *objc-class-class*)
71(defvar *objc-metaclass-class*)
72
73(defvar *objc-object-slot-vectors* (make-hash-table :test #'eql))
74(defvar *objc-canonical-instances* (make-hash-table :test #'eql :weak :value))
75
76(defun raw-macptr-for-instance (instance)
77  (let* ((p (%null-ptr)))
78    (%set-macptr-domain p 1)            ; not an ObjC object, but EQL to one
79    (%setf-macptr p instance)
80    p))
81
82(defun register-canonical-objc-instance (instance raw-ptr)
83  ;(terminate-when-unreachable instance)
84  ;(retain-objc-instance instance)
85  (setf (gethash raw-ptr *objc-canonical-instances*) instance))
86
87(defun canonicalize-objc-instance (instance)
88  (or (gethash instance *objc-canonical-instances*)
89      (register-canonical-objc-instance
90       (setq instance (%inc-ptr instance 0))
91       (raw-macptr-for-instance instance))))
92
93
94(defun recognize-objc-object (p)
95  (labels ((recognize (p mapped)
96             (let* ((idx (objc-class-id p)))
97               (if idx
98                 (%set-macptr-type p (dpb objc-flag-class objc-type-flags idx))
99                 (if (setq idx (objc-metaclass-id p))
100                   (%set-macptr-type p (dpb objc-flag-metaclass objc-type-flags idx))
101                   (if (setq idx (%objc-instance-class-index p))
102                     (%set-macptr-type p idx)
103                     (unless mapped
104                       (if (maybe-map-objc-classes)
105                         (recognize p t)))))))))
106    (recognize p nil)))
107
108(defun release-canonical-nsobject (object)
109  object)
110
111 
112
113(defun %objc-domain-class-of (p)
114  (let* ((type (%macptr-type p))
115         (flags (ldb objc-type-flags type))
116         (index (ldb objc-type-index type)))
117    (declare (fixnum type flags index))
118    (ecase flags
119      (#.objc-flag-instance (id->objc-class index))
120      (#.objc-flag-class (objc-class-id->objc-metaclass index))
121      (#.objc-flag-metaclass *objc-metaclass-class*))))
122 
123(defun %objc-domain-classp (p)
124  (let* ((type (%macptr-type p))
125         (flags (ldb objc-type-flags type)))
126    (declare (fixnum type flags))
127    (not (= flags objc-flag-instance))))
128
129(defun %objc-domain-instance-class-wrapper (p)
130  (let* ((type (%macptr-type p))
131         (flags (ldb objc-type-flags type))
132         (index (ldb objc-type-index type)))
133    (declare (fixnum type flags index))
134    (ecase flags
135      (#.objc-flag-instance (id->objc-class-wrapper index))
136      (#.objc-flag-class (id->objc-metaclass-wrapper (objc-class-id->objc-metaclass-id index)))
137      (#.objc-flag-metaclass (%class.own-wrapper *objc-metaclass-class*)))))
138
139(defun %objc-domain-class-own-wrapper (p)
140  (let* ((type (%macptr-type p))
141         (flags (ldb objc-type-flags type))
142         (index (ldb objc-type-index type)))
143    (declare (fixnum type flags index))
144    (ecase flags
145      (#.objc-flag-instance nil)
146      (#.objc-flag-class (id->objc-class-wrapper index))
147      (#.objc-flag-metaclass (id->objc-metaclass-wrapper index)))))
148
149(defun has-lisp-slot-vector (p)
150  (gethash p *objc-object-slot-vectors*))
151
152(defun %remove-lisp-slot-vector (p)
153  (remhash p *objc-object-slot-vectors*))
154
155(defun %objc-domain-slots-vector (p)
156       (let* ((type (%macptr-type p))
157             (flags (ldb objc-type-flags type))
158             (index (ldb objc-type-index type)))
159        (declare (fixnum type flags index))
160        (ecase flags
161          (#.objc-flag-instance (or (gethash p *objc-object-slot-vectors*)
162                                    ; try to allocate the slot vector on demand
163                                    (let* ((raw-ptr (raw-macptr-for-instance p))
164                                           (slot-vector (create-foreign-instance-slot-vector (class-of p))))
165                                      (when slot-vector
166                                        (setf (slot-vector.instance slot-vector) raw-ptr)
167                                        (setf (gethash raw-ptr *objc-object-slot-vectors*) slot-vector)
168                                        (register-canonical-objc-instance p raw-ptr)
169                                        (initialize-instance p))
170                                      slot-vector)
171                                    (error "~s has no slots." p)))
172          (#.objc-flag-class (id->objc-class-slots-vector index))
173          (#.objc-flag-metaclass (id->objc-metaclass-slots-vector index)))))
174
175(defun %objc-domain-class-ordinal (p)
176  (let* ((type (%macptr-type p))
177         (flags (ldb objc-type-flags type))
178         (index (ldb objc-type-index type)))
179    (declare (fixnum type flags index))
180    (ecase flags
181      (#.objc-flag-instance nil)
182      (#.objc-flag-class (objc-class-id->ordinal index))
183      (#.objc-flag-metaclass (objc-metaclass-id->ordinal index)))))
184
185(defun %set-objc-domain-class-ordinal (p new)
186  (let* ((type (%macptr-type p))
187         (flags (ldb objc-type-flags type))
188         (index (ldb objc-type-index type)))
189    (declare (fixnum type flags index))
190    (ecase flags
191      (#.objc-flag-instance nil)
192      (#.objc-flag-class (setf (objc-class-id->ordinal index) new))
193      (#.objc-flag-metaclass (setf (objc-metaclass-id->ordinal index) new)))))
194
195(defloadvar *objc-object-domain*
196    (register-foreign-object-domain :objc
197                                :recognize #'recognize-objc-object
198                                :class-of #'%objc-domain-class-of
199                                :classp #'%objc-domain-classp
200                                :instance-class-wrapper
201                                #'%objc-domain-instance-class-wrapper
202                                :class-own-wrapper
203                                #'%objc-domain-class-own-wrapper
204                                :slots-vector #'%objc-domain-slots-vector
205                                :class-ordinal #'%objc-domain-class-ordinal
206                                :set-class-ordinal
207                                #'%set-objc-domain-class-ordinal))
208
209;;; P is known to be a (possibly null!) instance of some ObjC class.
210(defun %set-objc-instance-type (p)
211  (unless (%null-ptr-p p)
212    (let* ((parent (pref p :objc_object.isa))
213           (id (objc-class-id parent)))
214      (when id
215        (%set-macptr-domain p *objc-object-domain*)
216        (%set-macptr-type p id)))))
217
218;;; P is known to be of type :ID.  It may be null.
219(defun %set-objc-id-type (p)
220  (let* ((idx (objc-class-id p)))
221    (if idx
222      (progn
223        (%set-macptr-domain p *objc-object-domain*)
224        (%set-macptr-type p (dpb objc-flag-class objc-type-flags idx)))
225      (if (setq idx (objc-metaclass-id p))
226        (progn
227          (%set-macptr-domain p *objc-object-domain*) 
228          (%set-macptr-type p (dpb objc-flag-metaclass objc-type-flags idx)))
229        (%set-objc-instance-type p)))))
230
231
232;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
233;;;;                  ObjC Objects, Classes and Metaclasses                 ;;;;
234;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
235
236(defclass objc:objc-object (foreign-standard-object)
237    ())
238
239;;; "Real" OBJC-CLASSes and OBJC-METACLASSEs are subtypes of this
240;;; abstract class.  We need to keep track of those classes that're
241;;; implemented in lisp separately (so that they can be restored after
242;;; SAVE-APPLICATION).
243
244(defclass objc:objc-class-object (foreign-class objc:objc-object)
245    ((foreign :initform nil :initarg :foreign)
246     (peer :initform nil :initarg :peer)))
247
248(defclass objc:objc-metaclass (objc:objc-class-object)
249    ())
250
251(setq *objc-metaclass-class* (find-class 'objc:objc-metaclass))
252
253(defclass objc:objc-class (objc:objc-class-object)
254    ())
255
256(setq *objc-class-class* (find-class 'objc:objc-class))
257
258(deftype @metaclass (&optional string)
259  (declare (ignore string))
260  'objc:objc-class)
261
262(defmethod objc-metaclass-p ((c class))
263  nil)
264
265(defmethod objc-metaclass-p ((c objc:objc-class-object))
266  (%objc-metaclass-p c))
267
268
269(defmethod print-object ((c objc:objc-class) stream)
270  (print-unreadable-object (c stream)
271    (format stream "~s ~:[~;[MetaClass] ~]~s (#x~x)" 
272            'objc:objc-class 
273            (objc-metaclass-p c) 
274            (if (slot-boundp c 'name)
275              (class-name c)
276              "<unnamed>")
277            (%ptr-to-int c))))
278
279(defmethod print-object ((c objc:objc-metaclass) stream)
280  (print-unreadable-object (c stream)
281    (format stream "~s ~s (#x~x)" 
282            'objc:objc-metaclass 
283            (if (slot-boundp c 'name)
284              (class-name c)
285              "<unnamed>") 
286            (%ptr-to-int c))))
287
288(defmethod print-object ((o objc:objc-object) stream)
289  (if (objc-object-p o)
290    (print-unreadable-object (o stream :type t)
291      (format stream
292              (if (and (typep o 'ns::ns-string)
293                       (initialized-nsobject-p o))
294                "~s (#x~x)"
295                "~a (#x~x)")
296              (nsobject-description o) (%ptr-to-int o)))
297    (format stream "#<Bogus ObjC Object #x~X>" (%ptr-to-int o))))
298
299
300
301 
302
303
304(defun make-objc-class-object-slots-vector (class meta)
305  (let* ((n (1+ (length (extract-instance-effective-slotds meta))))
306         (slots (allocate-typed-vector :slot-vector n (%slot-unbound-marker))))
307    (setf (slot-vector.instance slots) class)
308    slots))
309
310(defun make-objc-metaclass-slots-vector (metaclass)
311  (make-objc-class-object-slots-vector metaclass *objc-metaclass-class*))
312
313(defun make-objc-class-slots-vector (class)
314  (make-objc-class-object-slots-vector class *objc-class-class*))
315
316
317
318;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
319;;;;                              Slot Protocol                             ;;;;
320;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
321
322;;; Accessing Lisp slots
323
324(defmethod slot-boundp-using-class ((class objc:objc-class-object)
325                                    instance
326                                    (slotd standard-effective-slot-definition))
327  (%std-slot-vector-boundp (%objc-domain-slots-vector instance) slotd))
328
329(defmethod slot-value-using-class ((class objc:objc-class-object)
330                                   instance
331                                   (slotd standard-effective-slot-definition))
332  (%std-slot-vector-value (%objc-domain-slots-vector instance) slotd))
333
334(defmethod (setf slot-value-using-class)
335    (new
336     (class objc:objc-class-object)
337     instance
338     (slotd standard-effective-slot-definition))
339  (%set-std-slot-vector-value (%objc-domain-slots-vector instance) slotd new))
340
341
342;;; Metaclasses for foreign slots
343
344(defclass foreign-direct-slot-definition (direct-slot-definition)
345  ((foreign-type  :initform :id :accessor foreign-slot-definition-foreign-type)
346   (bit-offset :initarg :bit-offset
347               :initform nil
348               :accessor foreign-direct-slot-definition-bit-offset
349               :documentation "A bit-offset, relative to the start of the
350               instance's slots.  The corresponding effective slot definition's
351                offset is strictly determined by this value")))
352
353(defmethod shared-initialize :after ((slotd foreign-direct-slot-definition)
354                                     slot-names
355                                     &key (foreign-type :id))
356  (declare (ignore slot-names))
357  (unless (typep foreign-type 'foreign-type)
358    (setq foreign-type (parse-foreign-type foreign-type)))
359  (setf (foreign-slot-definition-foreign-type slotd) foreign-type))
360
361
362(defclass foreign-effective-slot-definition (effective-slot-definition)
363  ((foreign-type :initarg :foreign-type :initform :id :accessor foreign-slot-definition-foreign-type)
364   (getter :type function :accessor foreign-slot-definition-getter)
365   (setter :type function :accessor foreign-slot-definition-setter)))
366
367
368;;; Use the foreign slot metaclasses if the slot has a :FOREIGN-TYPE attribute
369;; 
370
371(defmethod direct-slot-definition-class ((class objc:objc-class-object)
372                                         &rest initargs)
373  (if (getf initargs :foreign-type)
374    (find-class 'foreign-direct-slot-definition)
375    (find-class 'standard-direct-slot-definition)))
376
377(defmethod effective-slot-definition-class ((class objc:objc-class-object)
378                                            &rest initargs)
379  (if (getf initargs :foreign-type)
380    (find-class 'foreign-effective-slot-definition)
381    (find-class 'standard-effective-slot-definition)))
382
383
384(defun set-objc-foreign-direct-slot-offsets (dslotds bit-offset)
385  (dolist (d dslotds)
386    (let* ((ftype (foreign-slot-definition-foreign-type d))
387           (type-alignment (progn (ensure-foreign-type-bits ftype)
388                                  (foreign-type-alignment ftype))))
389      (setf (foreign-direct-slot-definition-bit-offset d)
390            (setq bit-offset
391                  (align-offset bit-offset type-alignment)))
392      (setq bit-offset (+ bit-offset (foreign-type-bits ftype))))))
393
394(defmethod (setf class-direct-slots) :before (dslotds (class objc::objc-class))
395  #-(or apple-objc-2.0 cocotron-objc)
396  (let* ((foreign-dslotds
397          (loop for d in dslotds
398                when (typep d 'foreign-direct-slot-definition)
399                collect d))
400         (bit-offset (dolist (c (class-direct-superclasses class) 0)
401                       (when (typep c 'objc::objc-class)
402                         (return
403                           (ash (%objc-class-instance-size c)
404                                3))))))
405    (unless
406        (dolist (d foreign-dslotds t)
407          (if (not (foreign-direct-slot-definition-bit-offset d))
408            (return nil)))
409      (set-objc-foreign-direct-slot-offsets foreign-dslotds bit-offset)))
410  #+(or apple-objc-2.0 cocotron-objc)
411  ;; Add ivars for each foreign direct slot, then ask the runtime for
412  ;; the ivar's byte offset.  (Note that the ObjC 2.0 ivar initialization
413  ;; protocol doesn't seem to offer support for bitfield-valued ivars.)
414  (dolist (dslotd dslotds)
415    (when (typep dslotd 'foreign-direct-slot-definition)
416      (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd)))
417             (type (foreign-slot-definition-foreign-type dslotd))
418             (encoding (progn
419                         (ensure-foreign-type-bits type)
420                         (encode-objc-type type)))
421             (size (ceiling (foreign-type-bits type) 8))
422             (align (round (log (ceiling (foreign-type-alignment type) 8) 2))))
423        (with-cstrs ((name string)
424                     (encoding encoding))
425          (when (eql #$NO (#_class_addIvar class name size align encoding))
426            (error "class_addIvar failed"))
427          (with-macptrs ((ivar (#_class_getInstanceVariable class name)))
428            (unless (%null-ptr-p ivar)
429              (let* ((offset (#_ivar_getOffset ivar)))
430                (setf (foreign-direct-slot-definition-bit-offset dslotd)
431                      (ash offset 3))))))))))
432
433
434#+(or apple-objc-2.0 cocotron-objc)
435(defun %revive-foreign-slots (class)
436  (dolist (dslotd (class-direct-slots class))
437    (when (typep dslotd 'foreign-direct-slot-definition)
438      (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd)))
439             (type (foreign-slot-definition-foreign-type dslotd))
440             (encoding (progn
441                         (ensure-foreign-type-bits type)
442                         (encode-objc-type type)))
443             (size (ceiling (foreign-type-bits type) 8))
444             (align (round (log (ceiling (foreign-type-alignment type) 8) 2))))
445        (with-cstrs ((name string)
446                     (encoding encoding))
447          (#_class_addIvar class name size align encoding)
448          (with-macptrs ((ivar (#_class_getInstanceVariable class name)))
449              (unless (%null-ptr-p ivar)
450                (let* ((offset (#_ivar_getOffset ivar)))
451                  (unless (eql (foreign-direct-slot-definition-bit-offset dslotd)
452                               (ash offset 3))
453                    (dbg))))))))))
454
455(defun lisp-defined-slot-name-to-objc-slot-name (lisp-name)
456  (lisp-to-objc-message (list lisp-name)))
457
458;;; This is only going to be called on a class created by the user;
459;;; each foreign direct slotd's offset field should already have been
460;;; set to the slot's bit offset.
461#-(or apple-objc-2.0 cocotron-objc)
462(defun %make-objc-ivars (class)
463  (let* ((start-offset (superclass-instance-size class))
464         (foreign-dslotds (loop for s in (class-direct-slots class)
465                                when (typep s 'foreign-direct-slot-definition)
466                                collect s)))
467    (if (null foreign-dslotds)
468      (values (%null-ptr) start-offset)
469      (let* ((n (length foreign-dslotds))
470             (offset start-offset)
471             (ivars (malloc (+ 4 (* n (%foreign-type-or-record-size
472                                       :objc_ivar :bytes))))))
473      (setf (pref ivars :objc_ivar_list.ivar_count) n)
474      (do* ((l foreign-dslotds (cdr l))
475            (dslotd (car l) (car l))
476            (ivar (pref ivars :objc_ivar_list.ivar_list)
477                  (%inc-ptr ivar (%foreign-type-or-record-size
478                                 :objc_ivar :bytes))))
479           ((null l) (values ivars (ash (align-offset offset 32) 3)))
480        (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd)))
481               (type (foreign-slot-definition-foreign-type dslotd))
482               (encoding (progn
483                           (ensure-foreign-type-bits type)
484                           (encode-objc-type type))))
485          (setq offset (foreign-direct-slot-definition-bit-offset dslotd))
486          (setf (pref ivar :objc_ivar.ivar_name) (make-cstring string)
487                (pref ivar :objc_ivar.ivar_type) (make-cstring encoding)
488                (pref ivar :objc_ivar.ivar_offset) (ash offset -3))
489          (incf offset (foreign-type-bits type))))))))
490 
491 
492
493(defun %objc-ivar-offset-in-class (name c)
494  ;; If C is a non-null ObjC class that contains an instance variable
495  ;; named NAME, return that instance variable's offset,  else return
496  ;; NIL.
497  #+(or apple-objc-2.0 cocotron-objc)
498  (with-cstrs ((name name))
499    (with-macptrs ((ivar (#_class_getInstanceVariable c name)))
500      (unless (%null-ptr-p ivar)
501        (#_ivar_getOffset ivar))))
502  #-(or apple-objc-2.0 cocotron-objc)
503  (when (objc-class-p c)
504    (with-macptrs ((ivars (pref c :objc_class.ivars)))
505      (unless (%null-ptr-p ivars)
506        (loop with n = (pref ivars :objc_ivar_list.ivar_count)
507              for i from 1 to n
508              for ivar = (pref ivars :objc_ivar_list.ivar_list) 
509                  then (%inc-ptr ivar (record-length :objc_ivar))
510              when (string= name (%get-cstring (pref ivar :objc_ivar.ivar_name)))
511                do (return-from %objc-ivar-offset-in-class (pref ivar :objc_ivar.ivar_offset)))))))
512
513(defun %objc-ivar-offset (name c)
514  (labels ((locate-objc-slot (name class)
515             (unless (%null-ptr-p class)
516                 (or (%objc-ivar-offset-in-class name class)
517                     (with-macptrs ((super #+(or apple-objc-2.0 cocotron-objc)
518                                           (#_class_getSuperclass class)
519                                           #-(or apple-objc-2.0 cocotron-objc)
520                                           (pref class :objc_class.super_class)))
521                       (unless (or (%null-ptr-p super) (eql super class))
522                         (locate-objc-slot name super)))))))
523    (when (objc-class-p c)
524      (or (locate-objc-slot name c)
525          (error "No ObjC instance variable named ~S in ~S" name c)))))
526
527;;; Maintain the class wrapper of an ObjC class or metaclass.
528
529(defmethod (setf class-own-wrapper) :after (wrapper (class objc::objc-metaclass))
530  (setf (id->objc-metaclass-wrapper (objc-metaclass-id class)) wrapper))
531
532(defmethod (setf class-own-wrapper) :after (wrapper (class objc::objc-class))
533  (setf (id->objc-class-wrapper (objc-class-id class)) wrapper))
534
535;;; Return the getter and setter functions for a foreign slot
536;;; NOTE: Should be changed to use FOREIGN-TYPE-TO-REPRESENTATION-TYPE
537
538(defun compute-foreign-slot-accessors (eslotd)
539  (let* ((ftype (foreign-slot-definition-foreign-type eslotd))
540         (ordinal (foreign-type-ordinal ftype)))
541    (etypecase ftype
542      (foreign-integer-type
543       (let* ((bits (foreign-integer-type-bits ftype))
544              (align (foreign-integer-type-alignment ftype))
545              (signed (foreign-integer-type-signed ftype)))
546         (if (= bits align)
547           (case bits
548             (1 (values #'%get-bit #'%set-bit))
549             (8 (values (if signed #'%get-signed-byte #'%get-unsigned-byte)
550                        #'%set-byte))
551             (16 (values (if signed #'%get-signed-word #'%get-unsigned-word)
552                         #'%set-word))
553             (32 (values (if signed #'%get-signed-long #'%get-unsigned-long)
554                         #'%set-long))
555             (64 (if signed
556                   (values #'%%get-signed-longlong #'%%set-signed-longlong)
557                   (values #'%%get-unsigned-longlong #'%%set-unsigned-longlong)))
558             (t (values #'(lambda (ptr offset)
559                       (%get-bitfield ptr offset bits))
560                   #'(lambda (ptr offset new)
561                       (setf (%get-bitfield ptr offset bits) new)))))
562           (values #'(lambda (ptr offset)
563                       (%get-bitfield ptr offset bits))
564                   #'(lambda (ptr offset new)
565                       (setf (%get-bitfield ptr offset bits) new))))))
566      (foreign-double-float-type
567       (values #'%get-double-float #'%set-double-float))
568      (foreign-single-float-type
569       (values #'%get-single-float #'%set-single-float))
570      (foreign-pointer-type
571       (if (objc-id-type-p ftype)
572         (values #'%get-ptr #'%set-ptr)
573         (let* ((to (foreign-pointer-type-to ftype))
574                (to-ordinal (if to (foreign-type-ordinal to) 0)))
575           (values #'(lambda (ptr offset)
576                       (let* ((p (%null-ptr)))
577                         (%setf-macptr p (%get-ptr ptr offset))
578                         (unless (%null-ptr-p p)
579                           (%set-macptr-domain p 1)
580                           (%set-macptr-type p to-ordinal))
581                         p))
582                   #'%set-ptr))))
583      (foreign-mem-block-type
584       (let* ((nbytes (%foreign-type-or-record-size ftype :bytes)))
585         (values #'(lambda (ptr offset)
586                     (let* ((p (%inc-ptr ptr offset)))
587                       (%set-macptr-type p ordinal)
588                       p))
589                 #'(lambda (pointer offset new)
590                                (setf (%composite-pointer-ref
591                                       nbytes
592                                       pointer
593                                       offset)
594                                      new))))))))
595   
596
597
598;;; Shadow SLOT-CLASS's COMPUTE-EFFECTIVE-SLOT-DEFINITION with a
599;;; method for OBJC-CLASSes that sets up foreign slot info.
600
601(defmethod compute-effective-slot-definition :around ((class objc:objc-class-object)
602                                                      name
603                                                      direct-slots)
604  (let* ((first (first direct-slots)))
605    (if (not (typep first 'foreign-direct-slot-definition))
606      (call-next-method)
607      (let* ((initer (dolist (s direct-slots)
608                       (when (%slot-definition-initfunction s)
609                         (return s))))
610             (documentor (dolist (s direct-slots)
611                           (when (%slot-definition-documentation s)
612                             (return s))))
613             (initargs (let* ((initargs nil))
614                         (dolist (dslot direct-slots initargs)
615                           (dolist (dslot-arg (%slot-definition-initargs  dslot))
616                             (pushnew dslot-arg initargs :test #'eq)))))
617             (eslotd
618               (make-effective-slot-definition
619                class
620                :name name
621                :allocation :instance
622                :type (or (%slot-definition-type first) t)
623                :documentation (when documentor (nth-value
624                                      1
625                                      (%slot-definition-documentation
626                                       documentor)))
627                :class (%slot-definition-class first)
628                :initargs initargs
629                :initfunction (if initer
630                                (%slot-definition-initfunction initer))
631                :initform (if initer (%slot-definition-initform initer))
632                :foreign-type (foreign-slot-definition-foreign-type first))))
633      (multiple-value-bind (getter setter) (compute-foreign-slot-accessors eslotd)
634        (setf (foreign-slot-definition-getter eslotd) getter)
635        (setf (foreign-slot-definition-setter eslotd) setter))
636      eslotd))))
637
638(defun bit-offset-to-location (bit-offset foreign-type)
639  (ensure-foreign-type-bits foreign-type)
640  (let* ((bits (foreign-type-bits foreign-type)))
641    (if (or (= bits 1)
642            (and (not (typep foreign-type 'foreign-mem-block-type))
643                 (not (= bits (foreign-type-alignment foreign-type)))))
644      bit-offset
645      (ash bit-offset -3))))
646
647;;; Determine the location of each slot
648;;; An effective slot's location is
649;;; a) a function of the class's origin (superclass-instance-size)
650;;;    and the corresponding direct class's offset, if it's defined in the
651;;;    class (has a corresponding direct-slot-definition in the class)
652;;; b) Exactly the same as the superclass's version's location, because
653;;;    of single inheritance.
654
655(defun determine-foreign-slot-location (class slot-name)
656  (or
657   (dolist (d (class-direct-slots class))
658     (when (and (eq slot-name (slot-definition-name d))
659                (typep d 'foreign-direct-slot-definition))
660       (return (bit-offset-to-location
661                (foreign-direct-slot-definition-bit-offset d)
662                (foreign-slot-definition-foreign-type d )))))
663   (dolist (super (class-direct-superclasses class))
664     (when (typep super 'objc:objc-class) ; can be at most 1
665       (let* ((e (find slot-name (class-slots super) :key #'slot-definition-name)))
666         (when e (return (slot-definition-location e))))))
667   (error "Can't find slot definition for ~s in ~s" slot-name class)))
668         
669
670(defmethod compute-slots :around ((class objc:objc-class-object))
671  (flet ((foreign-slot-p (s) (typep s 'foreign-effective-slot-definition)))
672    (let* ((cpl (%class-precedence-list class))
673           (slots (call-next-method))
674           (instance-slots 
675            (remove-if #'foreign-slot-p 
676                       (remove :class slots :key #'%slot-definition-allocation)))
677           (class-slots (remove :instance slots :key #'%slot-definition-allocation))
678           (foreign-slots (remove-if-not #'foreign-slot-p slots)))
679      (setq instance-slots
680            (sort-effective-instance-slotds instance-slots class cpl))
681      (when *objc-clos-debug*
682        (format t "Instance slots: ~S~%Class Slots: ~S~%Foreign Slots: ~S~%"
683                instance-slots class-slots foreign-slots))
684      (loop for islot in instance-slots
685            for loc = 1 then (1+ loc)
686            do (setf (%slot-definition-location islot) loc))
687      (dolist (cslot class-slots)
688        (setf (%slot-definition-location cslot)
689              (assoc (%slot-definition-name cslot)
690                     (%class-get (%slot-definition-class cslot) :class-slots)
691                     :test #'eq)))
692      (dolist (fslot foreign-slots)
693        (setf (%slot-definition-location fslot)
694              (determine-foreign-slot-location
695               class
696               (%slot-definition-name fslot))))
697      (append instance-slots class-slots foreign-slots))))
698
699
700;;; Accessing foreign slots
701
702(defmethod slot-boundp-using-class ((class objc:objc-class-object)
703                                    instance
704                                    (slotd foreign-effective-slot-definition))
705  (declare (ignore class instance slotd))
706  ;; foreign slots are always bound
707  t)
708
709(defmethod slot-makunbound-using-class ((class objc:objc-class-object)
710                                        instance
711                                        (slotd foreign-effective-slot-definition))
712  (declare (ignore instance))
713  (error "Foreign slots cannot be unbound: ~S" (slot-definition-name slotd)))
714
715(defmethod slot-value-using-class ((class objc:objc-class-object)
716                                   instance
717                                   (slotd foreign-effective-slot-definition))
718  (funcall (foreign-slot-definition-getter slotd)
719           instance
720           (slot-definition-location slotd)))
721
722(defmethod (setf slot-value-using-class) (value
723                                          (class objc:objc-class-object)
724                                          instance
725                                          (slotd foreign-effective-slot-definition))
726  (funcall (foreign-slot-definition-setter slotd)
727           instance
728           (slot-definition-location slotd)
729           value))
730
731
732;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
733;;;;            Instance Allocation and Initialization Protocols            ;;;;
734;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
735
736(defmethod make-instance ((class objc:objc-class-object) &rest initargs)
737  (let ((instance (apply #'allocate-instance class initargs)))
738    (if (%null-ptr-p instance)
739      instance
740      (apply #'initialize-instance instance initargs))))
741
742
743(defun remove-slot-initargs (class initargs)
744  (let* ((slot-initargs (class-slot-initargs class))) ; cache this, maybe
745    (collect ((new-initargs))
746    (loop for l = initargs then (cddr l)
747          when (null l) do (return-from remove-slot-initargs (new-initargs))
748          unless (member (first l)  slot-initargs :test #'eq)
749          do
750          (new-initargs (car l))
751          (new-initargs (cadr l))))))
752
753(defun create-foreign-instance-slot-vector (class)
754  (let* ((max 0))
755    (dolist (slotd (class-slots class)
756             (unless (zerop max)
757               (allocate-typed-vector :slot-vector (1+ max) (%slot-unbound-marker))))
758      (when (typep slotd 'standard-effective-slot-definition)
759        (let* ((loc (slot-definition-location slotd)))
760          (if (> loc max)
761            (setq max loc)))))))
762
763               
764                                         
765(defmethod allocate-instance ((class objc:objc-class) &rest initargs &key &allow-other-keys)
766  (unless (class-finalized-p class)
767    (finalize-inheritance class))
768  (let* ((instance
769          (multiple-value-bind (ks vs) (keys-and-vals (remove-slot-initargs
770                                                       class
771                                                       initargs))
772            (send-objc-init-message (allocate-objc-object class) ks vs))))
773    (unless (%null-ptr-p instance)
774      (or (gethash instance *objc-object-slot-vectors*)
775          (let* ((slot-vector (create-foreign-instance-slot-vector class)))
776            (when slot-vector
777              (let* ((raw-ptr (raw-macptr-for-instance instance)))
778                (setf (slot-vector.instance slot-vector) raw-ptr)
779                (setf (gethash raw-ptr *objc-object-slot-vectors*) slot-vector)
780                (register-canonical-objc-instance instance raw-ptr))))))
781    instance))
782
783
784
785
786(defmethod initialize-instance ((instance objc:objc-object) &rest initargs)
787  (apply #'shared-initialize instance t initargs))
788
789(defmethod reinitialize-instance ((instance objc:objc-object) &rest initargs)
790  (apply #'shared-initialize instance nil initargs))
791
792(defmethod initialize-instance :after ((class objc:objc-class) &rest initargs)
793  (declare (ignore initargs))
794  (unless (slot-value class 'foreign)
795    #-(or apple-objc-2.0 cocotron-objc)
796    (multiple-value-bind (ivars instance-size)
797        (%make-objc-ivars class)
798      (%add-objc-class class ivars instance-size))
799    #+(or apple-objc-2.0 cocotron-objc)
800    (%add-objc-class class)))
801
802(defmethod shared-initialize ((instance objc:objc-object) slot-names 
803                              &rest initargs)
804  (let ((class (class-of instance)))
805    ;; Initialize CLOS slots
806    (dolist (slotd (class-slots class))
807      (when (not (typep slotd 'foreign-effective-slot-definition)) ; For now
808        (let ((sname (slot-definition-name slotd))
809              (slot-type (slot-definition-type slotd))
810              (typepred (slot-value slotd 'type-predicate))
811              (initfunction (slot-definition-initfunction slotd)))
812          (multiple-value-bind (ignore newval foundp)
813                               (get-properties initargs
814                                               (slot-definition-initargs slotd))
815            (declare (ignore ignore))
816            (if foundp
817                (if (or (null typepred)
818                        (funcall typepred newval))
819                    (setf (slot-value instance sname) newval)
820                  (report-bad-arg newval slot-type))
821              (let* ((loc (slot-definition-location slotd))
822                     (curval (%standard-instance-instance-location-access
823                             instance loc)))
824                (when (and (or (eq slot-names t) 
825                               (member sname slot-names :test #'eq))
826                           (eq curval (%slot-unbound-marker))
827                           initfunction)
828                  (let ((newval (funcall initfunction)))
829                    (unless (or (null typepred)
830                                (funcall typepred newval))
831                      (report-bad-arg newval slot-type))
832                    (setf (%standard-instance-instance-location-access
833                           instance loc)
834                          newval)))))))))
835    instance))
836
837(defmethod shared-initialize :after ((spec foreign-effective-slot-definition)
838                                     slot-names
839                                     &key &allow-other-keys)
840  (declare (ignore slot-names))
841  (setf (slot-value spec 'type-predicate) #'true))
842
843;;; The CLASS-OF an existing OBJC:OBJC-CLASS is an OBJC:OBJC-METACLASS,
844;;; but not necessarily the one specified as a :metaclass option to
845;;; DEFCLASS or ENSURE-CLASS.  Allow an existing class to be reinitialized,
846;;; as long as the specified :metaclass and the class's own class have
847;;; the same metaclass and specified metaclass is a root class.
848
849(defmethod ensure-class-using-class ((class objc:objc-class)
850                                     name
851                                     &rest keys &key)
852  (multiple-value-bind (metaclass initargs)
853      (ensure-class-metaclass-and-initargs class keys)
854    (let* ((existing-metaclass (class-of class)))
855      (if (and (eq (class-of metaclass)
856                   (class-of existing-metaclass))
857               ;; A root metaclass has the corresponding class as
858               ;; its superclass, and that class has no superclass.
859               (with-macptrs ((super #+(or apple-objc-2.0 cocotron-objc)
860                                     (#_class_getSuperclass metaclass)
861                                     #-(or apple-objc-2.0 cocotron-objc)
862                                     (pref metaclass :objc_class.super_class)))
863                 (and (not (%null-ptr-p super))
864                      (not (%objc-metaclass-p super))
865                      (%null-ptr-p
866                       #+(or apple-objc-2.0 cocotron-objc)
867                       (#_class_getSuperclass super)
868                       #-(or apple-objc-2.0 cocotron-objc)
869                       (pref super :objc_class.super_class)))))
870        ;; Whew! it's ok to reinitialize the class.
871        (progn
872          (apply #'reinitialize-instance class initargs)
873          (setf (find-class name) class))
874        (error "Can't change metaclass of ~s to ~s." class metaclass)))))
875
876 
877
878;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
879;;;;              Class Definition and Finalization Protocols               ;;;;
880;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
881
882;;; Create the ObjC class/metaclass pair and dress it up in its minimal CLOS garb
883;;; This currently requires that exactly one of DIRECT-SUPERCLASSES be a
884;;; already existing subclass of OBJC:OBJC-CLASS
885
886(defun compute-objc-variable-name (sym)
887  (let* ((pname (string sym))
888         (first-alpha (position-if #'alpha-char-p pname)))
889    (string-downcase
890     (apply #'string-cat 
891            (mapcar #'string-capitalize (split-if-char #\- pname :elide)))
892     :end (if first-alpha (1+ first-alpha) 1))))
893
894(defmethod allocate-instance ((metaclass objc:objc-metaclass) 
895                              &key name direct-superclasses
896                              &allow-other-keys)
897  (let ((superclass
898         (loop for s in direct-superclasses
899               when (typep s 'objc:objc-class)
900                 collect s into objc-supers
901               finally 
902               (if (= (length objc-supers) 1)
903                   (return (first objc-supers))
904                 (error "Exactly one OBJC:OBJC-CLASS must appear in ~S, found ~S" 
905                        direct-superclasses
906                        (length objc-supers))))))
907    (%allocate-objc-class name superclass)))
908
909(defmethod shared-initialize ((class objc:objc-class-object) slot-names &rest initargs)
910  (%shared-initialize class slot-names initargs))
911
912(defmethod validate-superclass ((c1 objc:objc-class) (c2 objc:objc-class))
913  t)
914
915(defmethod make-instances-obsolete ((class objc:objc-class))
916  class)
917
918;;; Reader/writer methods for instances of OBJC:OBJC-CLASS
919(defmethod reader-method-class ((class objc:objc-class)
920                                (dslotd direct-slot-definition)
921                                &rest initargs)
922  (declare (ignore initargs))
923  (find-class 'standard-reader-method))
924
925(defmethod writer-method-class ((class objc:objc-class)
926                                (dslotd direct-slot-definition)
927                                &rest initargs)
928  (declare (ignore initargs))
929  (find-class 'standard-writer-method))
930
931
932;;; By the time we see this, the slot name has been transformed to the form
933;;; "(load-time-value (ensure-slot-id <slot-name>))".
934;;; This only works if the setter is SETF inverse of the getter.
935(define-compiler-macro slot-id-value (&whole call instance slot-name &environment env)
936  (or
937   (let* ((type nil))
938     (if (and (symbolp instance)
939              (subtypep (setq type (cdr (assq 'type (nth-value 2 (variable-information instance env)))))
940                        'objc:objc-object)
941              (consp slot-name)
942              (eq (car slot-name) 'load-time-value)
943              (consp (cdr slot-name))
944              (null (cddr slot-name))
945              (eq (caadr slot-name) 'ensure-slot-id)
946              (consp (cdadr slot-name))
947              (null (cddadr slot-name))
948              (setq slot-name (cadadr slot-name))
949              (quoted-form-p slot-name)
950              (setq slot-name (cadr slot-name)))
951       (let* ((class (find-class type nil))
952              (eslotd (when class (find slot-name (class-slots class)
953                                        :key #'slot-definition-name))))
954         (when (typep eslotd 'foreign-effective-slot-definition)
955           (let* ((getter (foreign-slot-definition-getter eslotd))
956                  (name (if (typep getter 'compiled-function)
957                          (function-name getter))))
958             (when name
959               `(,name ,instance ,(slot-definition-location eslotd))))))))
960   call))
961
962
Note: See TracBrowser for help on using the repository browser.