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

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

Conditionalize for Cocotron/Win32. Seems to mostly work (except for
some issue related to registering new selectors) and Cocotron issue #331.
Smoke-tested on OSX; seems to be OK, but there's a non-zero chance that
I broke something.

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