source: tags/1.2/source/objc-bridge/objc-clos.lisp

Last change on this file was 9200, checked in by gb, 12 years ago

synch with trunk

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