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

Last change on this file since 12312 was 12312, checked in by gb, 11 years ago

HAS-LISP-SLOT-VECTOR, %REMOVE-LISP-SLOT-VECTOR.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 37.3 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  #+apple-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 (typep o 'ns::ns-string)
293                "~s (#x~x)"
294                "~a (#x~x)")
295              (nsobject-description o) (%ptr-to-int o)))
296    (format stream "#<Bogus ObjC Object #x~X>" (%ptr-to-int o))))
297
298
299
300 
301
302
303(defun make-objc-class-object-slots-vector (class meta)
304  (let* ((n (1+ (length (extract-instance-effective-slotds meta))))
305         (slots (allocate-typed-vector :slot-vector n (%slot-unbound-marker))))
306    (setf (slot-vector.instance slots) class)
307    slots))
308
309(defun make-objc-metaclass-slots-vector (metaclass)
310  (make-objc-class-object-slots-vector metaclass *objc-metaclass-class*))
311
312(defun make-objc-class-slots-vector (class)
313  (make-objc-class-object-slots-vector class *objc-class-class*))
314
315
316
317;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
318;;;;                              Slot Protocol                             ;;;;
319;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
320
321;;; Accessing Lisp slots
322
323(defmethod slot-boundp-using-class ((class objc:objc-class-object)
324                                    instance
325                                    (slotd standard-effective-slot-definition))
326  (%std-slot-vector-boundp (%objc-domain-slots-vector instance) slotd))
327
328(defmethod slot-value-using-class ((class objc:objc-class-object)
329                                   instance
330                                   (slotd standard-effective-slot-definition))
331  (%std-slot-vector-value (%objc-domain-slots-vector instance) slotd))
332
333(defmethod (setf slot-value-using-class)
334    (new
335     (class objc:objc-class-object)
336     instance
337     (slotd standard-effective-slot-definition))
338  (%set-std-slot-vector-value (%objc-domain-slots-vector instance) slotd new))
339
340
341;;; Metaclasses for foreign slots
342
343(defclass foreign-direct-slot-definition (direct-slot-definition)
344  ((foreign-type  :initform :id :accessor foreign-slot-definition-foreign-type)
345   (bit-offset :initarg :bit-offset
346               :initform nil
347               :accessor foreign-direct-slot-definition-bit-offset
348               :documentation "A bit-offset, relative to the start of the
349               instance's slots.  The corresponding effective slot definition's
350                offset is strictly determined by this value")))
351
352(defmethod shared-initialize :after ((slotd foreign-direct-slot-definition)
353                                     slot-names
354                                     &key (foreign-type :id))
355  (declare (ignore slot-names))
356  (unless (typep foreign-type 'foreign-type)
357    (setq foreign-type (parse-foreign-type foreign-type)))
358  (setf (foreign-slot-definition-foreign-type slotd) foreign-type))
359
360
361(defclass foreign-effective-slot-definition (effective-slot-definition)
362  ((foreign-type :initarg :foreign-type :initform :id :accessor foreign-slot-definition-foreign-type)
363   (getter :type function :accessor foreign-slot-definition-getter)
364   (setter :type function :accessor foreign-slot-definition-setter)))
365
366
367;;; Use the foreign slot metaclasses if the slot has a :FOREIGN-TYPE attribute
368;; 
369
370(defmethod direct-slot-definition-class ((class objc:objc-class-object)
371                                         &rest initargs)
372  (if (getf initargs :foreign-type)
373    (find-class 'foreign-direct-slot-definition)
374    (find-class 'standard-direct-slot-definition)))
375
376(defmethod effective-slot-definition-class ((class objc:objc-class-object)
377                                            &rest initargs)
378  (if (getf initargs :foreign-type)
379    (find-class 'foreign-effective-slot-definition)
380    (find-class 'standard-effective-slot-definition)))
381
382
383(defun set-objc-foreign-direct-slot-offsets (dslotds bit-offset)
384  (dolist (d dslotds)
385    (let* ((ftype (foreign-slot-definition-foreign-type d))
386           (type-alignment (progn (ensure-foreign-type-bits ftype)
387                                  (foreign-type-alignment ftype))))
388      (setf (foreign-direct-slot-definition-bit-offset d)
389            (setq bit-offset
390                  (align-offset bit-offset type-alignment)))
391      (setq bit-offset (+ bit-offset (foreign-type-bits ftype))))))
392
393(defmethod (setf class-direct-slots) :before (dslotds (class objc::objc-class))
394  #-apple-objc-2.0
395  (let* ((foreign-dslotds
396          (loop for d in dslotds
397                when (typep d 'foreign-direct-slot-definition)
398                collect d))
399         (bit-offset (dolist (c (class-direct-superclasses class) 0)
400                       (when (typep c 'objc::objc-class)
401                         (return
402                           (ash (%objc-class-instance-size c)
403                                3))))))
404    (unless
405        (dolist (d foreign-dslotds t)
406          (if (not (foreign-direct-slot-definition-bit-offset d))
407            (return nil)))
408      (set-objc-foreign-direct-slot-offsets foreign-dslotds bit-offset)))
409  #+apple-objc-2.0
410  ;; Add ivars for each foreign direct slot, then ask the runtime for
411  ;; the ivar's byte offset.  (Note that the ObjC 2.0 ivar initialization
412  ;; protocol doesn't seem to offer support for bitfield-valued ivars.)
413  (dolist (dslotd dslotds)
414    (when (typep dslotd 'foreign-direct-slot-definition)
415      (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd)))
416             (type (foreign-slot-definition-foreign-type dslotd))
417             (encoding (progn
418                         (ensure-foreign-type-bits type)
419                         (encode-objc-type type)))
420             (size (ceiling (foreign-type-bits type) 8))
421             (align (round (log (ceiling (foreign-type-alignment type) 8) 2))))
422        (with-cstrs ((name string)
423                     (encoding encoding))
424          (#_class_addIvar class name size align encoding)
425          (with-macptrs ((ivar (#_class_getInstanceVariable class name)))
426              (unless (%null-ptr-p ivar)
427                (let* ((offset (#_ivar_getOffset ivar)))
428                  (setf (foreign-direct-slot-definition-bit-offset dslotd)
429                        (ash offset 3))))))))))
430
431
432#+apple-objc-2.0
433(defun %revive-foreign-slots (class)
434  (dolist (dslotd (class-direct-slots class))
435    (when (typep dslotd 'foreign-direct-slot-definition)
436      (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd)))
437             (type (foreign-slot-definition-foreign-type dslotd))
438             (encoding (progn
439                         (ensure-foreign-type-bits type)
440                         (encode-objc-type type)))
441             (size (ceiling (foreign-type-bits type) 8))
442             (align (round (log (ceiling (foreign-type-alignment type) 8) 2))))
443        (with-cstrs ((name string)
444                     (encoding encoding))
445          (#_class_addIvar class name size align encoding)
446          (with-macptrs ((ivar (#_class_getInstanceVariable class name)))
447              (unless (%null-ptr-p ivar)
448                (let* ((offset (#_ivar_getOffset ivar)))
449                  (unless (eql (foreign-direct-slot-definition-bit-offset dslotd)
450                               (ash offset 3))
451                    (dbg))))))))))
452
453(defun lisp-defined-slot-name-to-objc-slot-name (lisp-name)
454  (lisp-to-objc-message (list lisp-name)))
455
456;;; This is only going to be called on a class created by the user;
457;;; each foreign direct slotd's offset field should already have been
458;;; set to the slot's bit offset.
459#-apple-objc-2.0
460(defun %make-objc-ivars (class)
461  (let* ((start-offset (superclass-instance-size class))
462         (foreign-dslotds (loop for s in (class-direct-slots class)
463                                when (typep s 'foreign-direct-slot-definition)
464                                collect s)))
465    (if (null foreign-dslotds)
466      (values (%null-ptr) start-offset)
467      (let* ((n (length foreign-dslotds))
468             (offset start-offset)
469             (ivars (malloc (+ 4 (* n (%foreign-type-or-record-size
470                                       :objc_ivar :bytes))))))
471      (setf (pref ivars :objc_ivar_list.ivar_count) n)
472      (do* ((l foreign-dslotds (cdr l))
473            (dslotd (car l) (car l))
474            (ivar (pref ivars :objc_ivar_list.ivar_list)
475                  (%inc-ptr ivar (%foreign-type-or-record-size
476                                 :objc_ivar :bytes))))
477           ((null l) (values ivars (ash (align-offset offset 32) 3)))
478        (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd)))
479               (type (foreign-slot-definition-foreign-type dslotd))
480               (encoding (progn
481                           (ensure-foreign-type-bits type)
482                           (encode-objc-type type))))
483          (setq offset (foreign-direct-slot-definition-bit-offset dslotd))
484          (setf (pref ivar :objc_ivar.ivar_name) (make-cstring string)
485                (pref ivar :objc_ivar.ivar_type) (make-cstring encoding)
486                (pref ivar :objc_ivar.ivar_offset) (ash offset -3))
487          (incf offset (foreign-type-bits type))))))))
488 
489 
490
491(defun %objc-ivar-offset-in-class (name c)
492  ;; If C is a non-null ObjC class that contains an instance variable
493  ;; named NAME, return that instance variable's offset,  else return
494  ;; NIL.
495  #+apple-objc-2.0
496  (with-cstrs ((name name))
497    (with-macptrs ((ivar (#_class_getInstanceVariable c name)))
498      (unless (%null-ptr-p ivar)
499        (#_ivar_getOffset ivar))))
500  #-apple-objc-2.0
501  (when (objc-class-p c)
502    (with-macptrs ((ivars (pref c :objc_class.ivars)))
503      (unless (%null-ptr-p ivars)
504        (loop with n = (pref ivars :objc_ivar_list.ivar_count)
505              for i from 1 to n
506              for ivar = (pref ivars :objc_ivar_list.ivar_list) 
507                  then (%inc-ptr ivar (record-length :objc_ivar))
508              when (string= name (%get-cstring (pref ivar :objc_ivar.ivar_name)))
509                do (return-from %objc-ivar-offset-in-class (pref ivar :objc_ivar.ivar_offset)))))))
510
511(defun %objc-ivar-offset (name c)
512  (labels ((locate-objc-slot (name class)
513             (unless (%null-ptr-p class)
514                 (or (%objc-ivar-offset-in-class name class)
515                     (with-macptrs ((super #+apple-objc-2.0
516                                           (#_class_getSuperclass class)
517                                           #-apple-objc-2.0
518                                           (pref class :objc_class.super_class)))
519                       (unless (or (%null-ptr-p super) (eql super class))
520                         (locate-objc-slot name super)))))))
521    (when (objc-class-p c)
522      (or (locate-objc-slot name c)
523          (error "No ObjC instance variable named ~S in ~S" name c)))))
524
525;;; Maintain the class wrapper of an ObjC class or metaclass.
526
527(defmethod (setf class-own-wrapper) :after (wrapper (class objc::objc-metaclass))
528  (setf (id->objc-metaclass-wrapper (objc-metaclass-id class)) wrapper))
529
530(defmethod (setf class-own-wrapper) :after (wrapper (class objc::objc-class))
531  (setf (id->objc-class-wrapper (objc-class-id class)) wrapper))
532
533;;; Return the getter and setter functions for a foreign slot
534;;; NOTE: Should be changed to use FOREIGN-TYPE-TO-REPRESENTATION-TYPE
535
536(defun compute-foreign-slot-accessors (eslotd)
537  (let* ((ftype (foreign-slot-definition-foreign-type eslotd))
538         (ordinal (foreign-type-ordinal ftype)))
539    (etypecase ftype
540      (foreign-integer-type
541       (let* ((bits (foreign-integer-type-bits ftype))
542              (align (foreign-integer-type-alignment ftype))
543              (signed (foreign-integer-type-signed ftype)))
544         (if (= bits align)
545           (ecase bits
546             (1 (values #'%get-bit #'%set-bit))
547             (8 (values (if signed #'%get-signed-byte #'%get-unsigned-byte)
548                        #'%set-byte))
549             (16 (values (if signed #'%get-signed-word #'%get-unsigned-word)
550                         #'%set-word))
551             (32 (values (if signed #'%get-signed-long #'%get-unsigned-long)
552                         #'%set-long))
553             (64 (if signed
554                   (values #'%%get-signed-longlong #'%%set-signed-longlong)
555                   (values #'%%get-unsigned-longlong #'%%set-unsigned-longlong))))
556           (values #'(lambda (ptr offset)
557                       (%get-bitfield ptr offset bits))
558                   #'(lambda (ptr offset new)
559                       (setf (%get-bitfield ptr offset bits) new))))))
560      (foreign-double-float-type
561       (values #'%get-double-float #'%set-double-float))
562      (foreign-single-float-type
563       (values #'%get-single-float #'%set-single-float))
564      (foreign-pointer-type
565       (if (objc-id-type-p ftype)
566         (values #'%get-ptr #'%set-ptr)
567         (let* ((to (foreign-pointer-type-to ftype))
568                (to-ordinal (if to (foreign-type-ordinal to) 0)))
569           (values #'(lambda (ptr offset)
570                       (let* ((p (%null-ptr)))
571                         (%setf-macptr p (%get-ptr ptr offset))
572                         (unless (%null-ptr-p p)
573                           (%set-macptr-domain p 1)
574                           (%set-macptr-type p to-ordinal))
575                         p))
576                   #'%set-ptr))))
577      (foreign-mem-block-type
578       (let* ((nbytes (%foreign-type-or-record-size ftype :bytes)))
579         (values #'(lambda (ptr offset)
580                     (let* ((p (%inc-ptr ptr offset)))
581                       (%set-macptr-type p ordinal)
582                       p))
583                 #'(lambda (pointer offset new)
584                                (setf (%composite-pointer-ref
585                                       nbytes
586                                       pointer
587                                       offset)
588                                      new))))))))
589   
590
591
592;;; Shadow SLOT-CLASS's COMPUTE-EFFECTIVE-SLOT-DEFINITION with a
593;;; method for OBJC-CLASSes that sets up foreign slot info.
594
595(defmethod compute-effective-slot-definition :around ((class objc:objc-class-object)
596                                                      name
597                                                      direct-slots)
598  (let* ((first (first direct-slots)))
599    (if (not (typep first 'foreign-direct-slot-definition))
600      (call-next-method)
601      (let* ((initer (dolist (s direct-slots)
602                       (when (%slot-definition-initfunction s)
603                         (return s))))
604             (documentor (dolist (s direct-slots)
605                           (when (%slot-definition-documentation s)
606                             (return s))))
607             (initargs (let* ((initargs nil))
608                         (dolist (dslot direct-slots initargs)
609                           (dolist (dslot-arg (%slot-definition-initargs  dslot))
610                             (pushnew dslot-arg initargs :test #'eq)))))
611             (eslotd
612               (make-effective-slot-definition
613                class
614                :name name
615                :allocation :instance
616                :type (or (%slot-definition-type first) t)
617                :documentation (when documentor (nth-value
618                                      1
619                                      (%slot-definition-documentation
620                                       documentor)))
621                :class (%slot-definition-class first)
622                :initargs initargs
623                :initfunction (if initer
624                                (%slot-definition-initfunction initer))
625                :initform (if initer (%slot-definition-initform initer))
626                :foreign-type (foreign-slot-definition-foreign-type first))))
627      (multiple-value-bind (getter setter) (compute-foreign-slot-accessors eslotd)
628        (setf (foreign-slot-definition-getter eslotd) getter)
629        (setf (foreign-slot-definition-setter eslotd) setter))
630      eslotd))))
631
632(defun bit-offset-to-location (bit-offset foreign-type)
633  (ensure-foreign-type-bits foreign-type)
634  (let* ((bits (foreign-type-bits foreign-type)))
635    (if (or (= bits 1)
636            (and (not (typep foreign-type 'foreign-mem-block-type))
637                 (not (= bits (foreign-type-alignment foreign-type)))))
638      bit-offset
639      (ash bit-offset -3))))
640
641;;; Determine the location of each slot
642;;; An effective slot's location is
643;;; a) a function of the class's origin (superclass-instance-size)
644;;;    and the corresponding direct class's offset, if it's defined in the
645;;;    class (has a corresponding direct-slot-definition in the class)
646;;; b) Exactly the same as the superclass's version's location, because
647;;;    of single inheritance.
648
649(defun determine-foreign-slot-location (class slot-name)
650  (or
651   (dolist (d (class-direct-slots class))
652     (when (and (eq slot-name (slot-definition-name d))
653                (typep d 'foreign-direct-slot-definition))
654       (return (bit-offset-to-location
655                (foreign-direct-slot-definition-bit-offset d)
656                (foreign-slot-definition-foreign-type d )))))
657   (dolist (super (class-direct-superclasses class))
658     (when (typep super 'objc:objc-class) ; can be at most 1
659       (let* ((e (find slot-name (class-slots super) :key #'slot-definition-name)))
660         (when e (return (slot-definition-location e))))))
661   (error "Can't find slot definition for ~s in ~s" slot-name class)))
662         
663
664(defmethod compute-slots :around ((class objc:objc-class-object))
665  (flet ((foreign-slot-p (s) (typep s 'foreign-effective-slot-definition)))
666    (let* ((cpl (%class-precedence-list class))
667           (slots (call-next-method))
668           (instance-slots 
669            (remove-if #'foreign-slot-p 
670                       (remove :class slots :key #'%slot-definition-allocation)))
671           (class-slots (remove :instance slots :key #'%slot-definition-allocation))
672           (foreign-slots (remove-if-not #'foreign-slot-p slots)))
673      (setq instance-slots
674            (sort-effective-instance-slotds instance-slots class cpl))
675      (when *objc-clos-debug*
676        (format t "Instance slots: ~S~%Class Slots: ~S~%Foreign Slots: ~S~%"
677                instance-slots class-slots foreign-slots))
678      (loop for islot in instance-slots
679            for loc = 1 then (1+ loc)
680            do (setf (%slot-definition-location islot) loc))
681      (dolist (cslot class-slots)
682        (setf (%slot-definition-location cslot)
683              (assoc (%slot-definition-name cslot)
684                     (%class-get (%slot-definition-class cslot) :class-slots)
685                     :test #'eq)))
686      (dolist (fslot foreign-slots)
687        (setf (%slot-definition-location fslot)
688              (determine-foreign-slot-location
689               class
690               (%slot-definition-name fslot))))
691      (append instance-slots class-slots foreign-slots))))
692
693
694;;; Accessing foreign slots
695
696(defmethod slot-boundp-using-class ((class objc:objc-class-object)
697                                    instance
698                                    (slotd foreign-effective-slot-definition))
699  (declare (ignore class instance slotd))
700  ;; foreign slots are always bound
701  t)
702
703(defmethod slot-makunbound-using-class ((class objc:objc-class-object)
704                                        instance
705                                        (slotd foreign-effective-slot-definition))
706  (declare (ignore instance))
707  (error "Foreign slots cannot be unbound: ~S" (slot-definition-name slotd)))
708
709(defmethod slot-value-using-class ((class objc:objc-class-object)
710                                   instance
711                                   (slotd foreign-effective-slot-definition))
712  (funcall (foreign-slot-definition-getter slotd)
713           instance
714           (slot-definition-location slotd)))
715
716(defmethod (setf slot-value-using-class) (value
717                                          (class objc:objc-class-object)
718                                          instance
719                                          (slotd foreign-effective-slot-definition))
720  (funcall (foreign-slot-definition-setter slotd)
721           instance
722           (slot-definition-location slotd)
723           value))
724
725
726;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
727;;;;            Instance Allocation and Initialization Protocols            ;;;;
728;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
729
730(defmethod make-instance ((class objc:objc-class-object) &rest initargs)
731  (let ((instance (apply #'allocate-instance class initargs)))
732    (if (%null-ptr-p instance)
733      instance
734      (apply #'initialize-instance instance initargs))))
735
736
737(defun remove-slot-initargs (class initargs)
738  (let* ((slot-initargs (class-slot-initargs class))) ; cache this, maybe
739    (collect ((new-initargs))
740    (loop for l = initargs then (cddr l)
741          when (null l) do (return-from remove-slot-initargs (new-initargs))
742          unless (member (first l)  slot-initargs :test #'eq)
743          do
744          (new-initargs (car l))
745          (new-initargs (cadr l))))))
746
747(defun create-foreign-instance-slot-vector (class)
748  (let* ((max 0))
749    (dolist (slotd (class-slots class)
750             (unless (zerop max)
751               (allocate-typed-vector :slot-vector (1+ max) (%slot-unbound-marker))))
752      (when (typep slotd 'standard-effective-slot-definition)
753        (let* ((loc (slot-definition-location slotd)))
754          (if (> loc max)
755            (setq max loc)))))))
756
757               
758                                         
759(defmethod allocate-instance ((class objc:objc-class) &rest initargs &key &allow-other-keys)
760  (unless (class-finalized-p class)
761    (finalize-inheritance class))
762  (let* ((instance
763          (multiple-value-bind (ks vs) (keys-and-vals (remove-slot-initargs
764                                                       class
765                                                       initargs))
766            (send-objc-init-message (allocate-objc-object class) ks vs))))
767    (unless (%null-ptr-p instance)
768      (or (gethash instance *objc-object-slot-vectors*)
769          (let* ((slot-vector (create-foreign-instance-slot-vector class)))
770            (when slot-vector
771              (let* ((raw-ptr (raw-macptr-for-instance instance)))
772                (setf (slot-vector.instance slot-vector) raw-ptr)
773                (setf (gethash raw-ptr *objc-object-slot-vectors*) slot-vector)
774                (register-canonical-objc-instance instance raw-ptr))))))
775    instance))
776
777
778
779
780(defmethod initialize-instance ((instance objc:objc-object) &rest initargs)
781  (apply #'shared-initialize instance t initargs))
782
783(defmethod reinitialize-instance ((instance objc:objc-object) &rest initargs)
784  (apply #'shared-initialize instance nil initargs))
785
786(defmethod initialize-instance :after ((class objc:objc-class) &rest initargs)
787  (declare (ignore initargs))
788  (unless (slot-value class 'foreign)
789    #-apple-objc-2.0
790    (multiple-value-bind (ivars instance-size)
791        (%make-objc-ivars class)
792      (%add-objc-class class ivars instance-size))
793    #+apple-objc-2.0
794    (%add-objc-class class)))
795
796(defmethod shared-initialize ((instance objc:objc-object) slot-names 
797                              &rest initargs)
798  (let ((class (class-of instance)))
799    ;; Initialize CLOS slots
800    (dolist (slotd (class-slots class))
801      (when (not (typep slotd 'foreign-effective-slot-definition)) ; For now
802        (let ((sname (slot-definition-name slotd))
803              (slot-type (slot-definition-type slotd))
804              (typepred (slot-value slotd 'type-predicate))
805              (initfunction (slot-definition-initfunction slotd)))
806          (multiple-value-bind (ignore newval foundp)
807                               (get-properties initargs
808                                               (slot-definition-initargs slotd))
809            (declare (ignore ignore))
810            (if foundp
811                (if (or (null typepred)
812                        (funcall typepred newval))
813                    (setf (slot-value instance sname) newval)
814                  (report-bad-arg newval slot-type))
815              (let* ((loc (slot-definition-location slotd))
816                     (curval (%standard-instance-instance-location-access
817                             instance loc)))
818                (when (and (or (eq slot-names t) 
819                               (member sname slot-names :test #'eq))
820                           (eq curval (%slot-unbound-marker))
821                           initfunction)
822                  (let ((newval (funcall initfunction)))
823                    (unless (or (null typepred)
824                                (funcall typepred newval))
825                      (report-bad-arg newval slot-type))
826                    (setf (%standard-instance-instance-location-access
827                           instance loc)
828                          newval)))))))))
829    instance))
830
831(defmethod shared-initialize :after ((spec foreign-effective-slot-definition)
832                                     slot-names
833                                     &key &allow-other-keys)
834  (declare (ignore slot-names))
835  (setf (slot-value spec 'type-predicate) #'true))
836
837;;; The CLASS-OF an existing OBJC:OBJC-CLASS is an OBJC:OBJC-METACLASS,
838;;; but not necessarily the one specified as a :metaclass option to
839;;; DEFCLASS or ENSURE-CLASS.  Allow an existing class to be reinitialized,
840;;; as long as the specified :metaclass and the class's own class have
841;;; the same metaclass and specified metaclass is a root class.
842
843(defmethod ensure-class-using-class ((class objc:objc-class)
844                                     name
845                                     &rest keys &key)
846  (multiple-value-bind (metaclass initargs)
847      (ensure-class-metaclass-and-initargs class keys)
848    (let* ((existing-metaclass (class-of class)))
849      (if (and (eq (class-of metaclass)
850                   (class-of existing-metaclass))
851               ;; A root metaclass has the corresponding class as
852               ;; its superclass, and that class has no superclass.
853               (with-macptrs ((super #+apple-objc-2.0
854                                     (#_class_getSuperclass metaclass)
855                                     #-apple-objc-2.0
856                                     (pref metaclass :objc_class.super_class)))
857                 (and (not (%null-ptr-p super))
858                      (not (%objc-metaclass-p super))
859                      (%null-ptr-p
860                       #+apple-objc-2.0
861                       (#_class_getSuperclass super)
862                       #-apple-objc-2.0
863                       (pref super :objc_class.super_class)))))
864        ;; Whew! it's ok to reinitialize the class.
865        (progn
866          (apply #'reinitialize-instance class initargs)
867          (setf (find-class name) class))
868        (error "Can't change metaclass of ~s to ~s." class metaclass)))))
869
870 
871
872;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
873;;;;              Class Definition and Finalization Protocols               ;;;;
874;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
875
876;;; Create the ObjC class/metaclass pair and dress it up in its minimal CLOS garb
877;;; This currently requires that exactly one of DIRECT-SUPERCLASSES be a
878;;; already existing subclass of OBJC:OBJC-CLASS
879
880(defun compute-objc-variable-name (sym)
881  (let* ((pname (string sym))
882         (first-alpha (position-if #'alpha-char-p pname)))
883    (string-downcase
884     (apply #'string-cat 
885            (mapcar #'string-capitalize (split-if-char #\- pname :elide)))
886     :end (if first-alpha (1+ first-alpha) 1))))
887
888(defmethod allocate-instance ((metaclass objc:objc-metaclass) 
889                              &key name direct-superclasses
890                              &allow-other-keys)
891  (let ((superclass
892         (loop for s in direct-superclasses
893               when (typep s 'objc:objc-class)
894                 collect s into objc-supers
895               finally 
896               (if (= (length objc-supers) 1)
897                   (return (first objc-supers))
898                 (error "Exactly one OBJC:OBJC-CLASS must appear in ~S, found ~S" 
899                        direct-superclasses
900                        (length objc-supers))))))
901    (%allocate-objc-class name superclass)))
902
903(defmethod shared-initialize ((class objc:objc-class-object) slot-names &rest initargs)
904  (%shared-initialize class slot-names initargs))
905
906(defmethod validate-superclass ((c1 objc:objc-class) (c2 objc:objc-class))
907  t)
908
909(defmethod make-instances-obsolete ((class objc:objc-class))
910  class)
911
912;;; Reader/writer methods for instances of OBJC:OBJC-CLASS
913(defmethod reader-method-class ((class objc:objc-class)
914                                (dslotd direct-slot-definition)
915                                &rest initargs)
916  (declare (ignore initargs))
917  (find-class 'standard-reader-method))
918
919(defmethod writer-method-class ((class objc:objc-class)
920                                (dslotd direct-slot-definition)
921                                &rest initargs)
922  (declare (ignore initargs))
923  (find-class 'standard-writer-method))
924
925
926;;; By the time we see this, the slot name has been transformed to the form
927;;; "(load-time-value (ensure-slot-id <slot-name>))".
928;;; This only works if the setter is SETF inverse of the getter.
929(define-compiler-macro slot-id-value (&whole call instance slot-name &environment env)
930  (or
931   (let* ((type nil))
932     (if (and (symbolp instance)
933              (subtypep (setq type (cdr (assq 'type (nth-value 2 (variable-information instance env)))))
934                        'objc:objc-object)
935              (consp slot-name)
936              (eq (car slot-name) 'load-time-value)
937              (consp (cdr slot-name))
938              (null (cddr slot-name))
939              (eq (caadr slot-name) 'ensure-slot-id)
940              (consp (cdadr slot-name))
941              (null (cddadr slot-name))
942              (setq slot-name (cadadr slot-name))
943              (quoted-form-p slot-name)
944              (setq slot-name (cadr slot-name)))
945       (let* ((class (find-class type nil))
946              (eslotd (when class (find slot-name (class-slots class)
947                                        :key #'slot-definition-name))))
948         (when (typep eslotd 'foreign-effective-slot-definition)
949           (let* ((getter (foreign-slot-definition-getter eslotd))
950                  (name (if (typep getter 'compiled-function)
951                          (function-name getter))))
952             (when name
953               `(,name ,instance ,(slot-definition-location eslotd))))))))
954   call))
955
956
Note: See TracBrowser for help on using the repository browser.