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

Last change on this file since 14290 was 14290, checked in by gb, 9 years ago

Learn (once again) how to write disturbingly simple code.

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