source: trunk/ccl/examples/objc-clos.lisp @ 6248

Last change on this file since 6248 was 6248, checked in by gb, 14 years ago

ALLOCATE-INSTANCE of OBJC:OBJC:CLASS: if the result of sending the
init message is a null pointer, return a null pointer.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 46.9 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2003-2004 Clozure Associates and contributors.
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16;;;
17;;; TO DO
18;;;  - Both method creation and invocation should be faster and cons less
19;;;  - Resolve messages with repeated keywords
20;;;    (rename them to :range1:range2 or don't use &key in GFs and methods)
21;;;  - How to integrate SEND-SUPER with CALL-NEXT-METHOD?
22;;;  - Variable arity ObjC methods
23;;;  - Pass-by-ref structures need to keep track of IN, OUT, IN/OUT info
24;;;  - Need to canonicalize and retain every returned :ID
25;;;  - Support :BEFORE, :AFTER and :AROUND for ObjC methods
26;;;  - User-defined ObjC methods via DEFMETHOD (or DEFINE-OBJ-METHOD)
27;;;  - Need to fully handle init keywords and ObjC init messages
28
29;;; Package and module stuff
30
31(in-package "CCL")
32
33(eval-when (:compile-toplevel :execute)
34  #+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;;; ObjC messages that cannot currently be translated into CLOS methods
48
49(defparameter *troublesome-messages*
50  '(
51    ;; Multicolon messages that don't respect the name translation rules
52    "performv::" "translateTo::" "indexOf:::" "scaleTo::" "forward::" 
53    "exchange::"
54    ;; Messages involving the nonexistent NSButtonState
55    "focusRingImageForState:" "useDisabledEffectForState:"
56    "isBorderedForState:" "imageForState:" "useHighlightEffectForState:"
57    "isOpaqueForState:" "bezelStyleForState:"
58    ;; Messages containing repeated keywords
59    "orderString:range:string:range:flags:"
60    "parseSuiteOfPairsKey:separator:value:separator:allowOmitLastSeparator:" 
61    "perform:with:with:" 
62    "perform:withObject:withObject:" 
63    "performSelector:withObject:withObject:" 
64    ;; Variable arity messages
65    "appendFormat:" "arrayWithObjects:" "encodeValuesOfObjCTypes:"
66    "decodeValuesOfObjCTypes:" "dictinaryWithObjectsAndKeys:"
67    "handleFailureInFunction:object:file:lineNumber:description:"
68    "handleFailureInMethod:object:file:lineNumber:description:"
69    "initWithFormat:" "initWithObjects:" "initWithObjectsAndKeys:"
70    "initWithFormat:locale:" "localizedStringWithFormat:" "raise:format:"
71    "setWithObjects:" "stringByAppendingFormat:" "stringWithFormat:"
72    ;; Seems to involve a (:STRUCT :?) argument
73    "percentEscapeDecodeBuffer:range:stripWhitespace:"))
74
75(defun troublesome-message-p (msg)
76  (if (member msg *troublesome-messages* :test #'string=) t nil))
77
78
79;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
80;;;;                                 Testing                                ;;;;
81;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
82
83;;; Enable some debugging output.
84(defparameter *objc-clos-debug* nil)
85
86
87
88
89;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
90;;;;                     OBJC Foreign Object Domain                         ;;;;
91;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
92
93(defconstant objc-type-flags (byte 3 20))
94(defconstant objc-type-index (byte 20 0))
95(defconstant objc-flag-instance 0)
96(defconstant objc-flag-class 1)
97(defconstant objc-flag-metaclass 2)
98
99(defvar *objc-class-class*)
100(defvar *objc-metaclass-class*)
101
102(defvar *objc-object-slot-vectors* (make-hash-table :test #'eql))
103(defvar *objc-canonical-instances* (make-hash-table :test #'eql :weak :value))
104
105(defun raw-macptr-for-instance (instance)
106  (let* ((p (%null-ptr)))
107    (%set-macptr-domain p 1)            ; not an ObjC object, but EQL to one
108    (%setf-macptr p instance)
109    p))
110
111(defun register-canonical-objc-instance (instance raw-ptr)
112  ;(terminate-when-unreachable instance)
113  ;(retain-objc-instance instance)
114  (setf (gethash raw-ptr *objc-canonical-instances*) instance))
115
116(defun canonicalize-objc-instance (instance)
117  (or (gethash instance *objc-canonical-instances*)
118      (register-canonical-objc-instance
119       (setq instance (%inc-ptr instance 0))
120       (raw-macptr-for-instance instance))))
121
122
123(defun recognize-objc-object (p)
124  (labels ((recognize (p mapped)
125             (let* ((idx (objc-class-id p)))
126               (if idx
127                 (%set-macptr-type p (dpb objc-flag-class objc-type-flags idx))
128                 (if (setq idx (objc-metaclass-id p))
129                   (%set-macptr-type p (dpb objc-flag-metaclass objc-type-flags idx))
130                   (if (setq idx (%objc-instance-class-index p))
131                     (%set-macptr-type p idx)
132                     (unless mapped
133                       (if (maybe-map-objc-classes)
134                         (recognize p t)))))))))
135    (recognize p nil)))
136
137(defun release-canonical-nsobject (object)
138  object)
139
140 
141
142(defun %objc-domain-class-of (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 (id->objc-class index))
149      (#.objc-flag-class (objc-class-id->objc-metaclass index))
150      (#.objc-flag-metaclass *objc-metaclass-class*))))
151 
152(defun %objc-domain-classp (p)
153  (let* ((type (%macptr-type p))
154         (flags (ldb objc-type-flags type)))
155    (declare (fixnum type flags))
156    (not (= flags objc-flag-instance))))
157
158(defun %objc-domain-instance-class-wrapper (p)
159  (let* ((type (%macptr-type p))
160         (flags (ldb objc-type-flags type))
161         (index (ldb objc-type-index type)))
162    (declare (fixnum type flags index))
163    (ecase flags
164      (#.objc-flag-instance (id->objc-class-wrapper index))
165      (#.objc-flag-class (id->objc-metaclass-wrapper (objc-class-id->objc-metaclass-id index)))
166      (#.objc-flag-metaclass (%class.own-wrapper *objc-metaclass-class*)))))
167
168(defun %objc-domain-class-own-wrapper (p)
169  (let* ((type (%macptr-type p))
170         (flags (ldb objc-type-flags type))
171         (index (ldb objc-type-index type)))
172    (declare (fixnum type flags index))
173    (ecase flags
174      (#.objc-flag-instance nil)
175      (#.objc-flag-class (id->objc-class-wrapper index))
176      (#.objc-flag-metaclass (id->objc-metaclass-wrapper index)))))
177
178(defun %objc-domain-slots-vector (p)
179       (let* ((type (%macptr-type p))
180             (flags (ldb objc-type-flags type))
181             (index (ldb objc-type-index type)))
182        (declare (fixnum type flags index))
183        (ecase flags
184          (#.objc-flag-instance (or (gethash p *objc-object-slot-vectors*)
185                                    ; try to allocate the slot vector on demand
186                                    (let* ((raw-ptr (raw-macptr-for-instance p))
187                                           (slot-vector (create-foreign-instance-slot-vector (class-of 
188p))))
189                                      (when slot-vector
190                                        (setf (slot-vector.instance slot-vector) raw-ptr)
191                                        (setf (gethash raw-ptr *objc-object-slot-vectors*) slot-vector)
192                                        (register-canonical-objc-instance p raw-ptr)
193                                        (initialize-instance p))
194                                      slot-vector)
195                                    (error "~s has no slots." p)))
196          (#.objc-flag-class (id->objc-class-slots-vector index))
197          (#.objc-flag-metaclass (id->objc-metaclass-slots-vector index)))))
198         
199(defloadvar *objc-object-domain*
200    (register-foreign-object-domain :objc
201                                :recognize #'recognize-objc-object
202                                :class-of #'%objc-domain-class-of
203                                :classp #'%objc-domain-classp
204                                :instance-class-wrapper
205                                #'%objc-domain-instance-class-wrapper
206                                :class-own-wrapper
207                                #'%objc-domain-class-own-wrapper
208                                :slots-vector #'%objc-domain-slots-vector))
209
210;;; P is known to be a (possibly null!) instance of some ObjC class.
211(defun %set-objc-instance-type (p)
212  (unless (%null-ptr-p p)
213    (let* ((parent (pref p :objc_object.isa))
214           (id (objc-class-id parent)))
215      (when id
216        (%set-macptr-domain p *objc-object-domain*)
217        (%set-macptr-type p id)))))
218
219;;; P is known to be of type :ID.  It may be null.
220(defun %set-objc-id-type (p)
221  (let* ((idx (objc-class-id p)))
222    (if idx
223      (progn
224        (%set-macptr-domain p *objc-object-domain*)
225        (%set-macptr-type p (dpb objc-flag-class objc-type-flags idx)))
226      (if (setq idx (objc-metaclass-id p))
227        (progn
228          (%set-macptr-domain p *objc-object-domain*) 
229          (%set-macptr-type p (dpb objc-flag-metaclass objc-type-flags idx)))
230        (%set-objc-instance-type p)))))
231
232
233;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
234;;;;                  ObjC Objects, Classes and Metaclasses                 ;;;;
235;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
236
237(defclass objc:objc-object (foreign-standard-object)
238    ())
239
240;;; "Real" OBJC-CLASSes and OBJC-METACLASSEs are subtypes of this
241;;; abstract class.  We need to keep track of those classes that're
242;;; implemented in lisp separately (so that they can be restored after
243;;; SAVE-APPLICATION).
244
245(defclass objc:objc-class-object (foreign-class objc:objc-object)
246    ((foreign :initform nil :initarg :foreign)
247     (peer :initform nil :initarg :peer)))
248
249(defclass objc:objc-metaclass (objc:objc-class-object)
250    ())
251
252(setq *objc-metaclass-class* (find-class 'objc:objc-metaclass))
253
254(defclass objc:objc-class (objc:objc-class-object)
255    ())
256
257(setq *objc-class-class* (find-class 'objc:objc-class))
258
259(defmethod objc-metaclass-p ((c class))
260  nil)
261
262(defmethod objc-metaclass-p ((c objc:objc-class-object))
263  (%objc-metaclass-p c))
264
265
266(defmethod print-object ((c objc:objc-class) stream)
267  (print-unreadable-object (c stream)
268    (format stream "~s ~:[~;[MetaClass] ~]~s (#x~x)" 
269            'objc:objc-class 
270            (objc-metaclass-p c) 
271            (if (slot-boundp c 'name)
272              (class-name c)
273              "<unnamed>")
274            (%ptr-to-int c))))
275
276(defmethod print-object ((c objc:objc-metaclass) stream)
277  (print-unreadable-object (c stream)
278    (format stream "~s ~s (#x~x)" 
279            'objc:objc-metaclass 
280            (if (slot-boundp c 'name)
281              (class-name c)
282              "<unnamed>") 
283            (%ptr-to-int c))))
284
285(defmethod print-object ((o objc:objc-object) stream)
286  (if (objc-object-p o)
287    (print-unreadable-object (o stream :type t)
288      (format stream
289              (if (typep o 'ns::ns-string)
290                "~s (#x~x)"
291                "~a (#x~x)")
292              (nsobject-description o) (%ptr-to-int o)))
293    (format stream "#<Bogus ObjC Object #x~X>" (%ptr-to-int o))))
294
295
296
297 
298
299
300(defun make-objc-class-object-slots-vector (class meta)
301  (let* ((n (1+ (length (extract-instance-effective-slotds meta))))
302         (slots (allocate-typed-vector :slot-vector n (%slot-unbound-marker))))
303    (setf (slot-vector.instance slots) class)
304    slots))
305
306(defun make-objc-metaclass-slots-vector (metaclass)
307  (make-objc-class-object-slots-vector metaclass *objc-metaclass-class*))
308
309(defun make-objc-class-slots-vector (class)
310  (make-objc-class-object-slots-vector class *objc-class-class*))
311
312
313
314;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
315;;;;                              Slot Protocol                             ;;;;
316;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
317
318;;; Accessing Lisp slots
319
320(defmethod slot-boundp-using-class ((class objc:objc-class-object)
321                                    instance
322                                    (slotd standard-effective-slot-definition))
323  (%std-slot-vector-boundp (%objc-domain-slots-vector instance) slotd))
324
325(defmethod slot-value-using-class ((class objc:objc-class-object)
326                                   instance
327                                   (slotd standard-effective-slot-definition))
328  (%std-slot-vector-value (%objc-domain-slots-vector instance) slotd))
329
330(defmethod (setf slot-value-using-class)
331    (new
332     (class objc:objc-class-object)
333     instance
334     (slotd standard-effective-slot-definition))
335  (%set-std-slot-vector-value (%objc-domain-slots-vector instance) slotd new))
336
337
338;;; Metaclasses for foreign slots
339
340(defclass foreign-direct-slot-definition (direct-slot-definition)
341  ((foreign-type  :initform :id :accessor foreign-slot-definition-foreign-type)
342   (bit-offset :initarg :bit-offset
343               :initform nil
344               :accessor foreign-direct-slot-definition-bit-offset
345               :documentation "A bit-offset, relative to the start of the
346               instance's slots.  The corresponding effective slot definition's
347                offset is strictly determined by this value")))
348
349(defmethod shared-initialize :after ((slotd foreign-direct-slot-definition)
350                                     slot-names
351                                     &key (foreign-type :id))
352  (declare (ignore slot-names))
353  (unless (typep foreign-type 'foreign-type)
354    (setq foreign-type (parse-foreign-type foreign-type)))
355  (setf (foreign-slot-definition-foreign-type slotd) foreign-type))
356
357
358(defclass foreign-effective-slot-definition (effective-slot-definition)
359  ((foreign-type :initarg :foreign-type :initform :id :accessor foreign-slot-definition-foreign-type)
360   (getter :type function :accessor foreign-slot-definition-getter)
361   (setter :type function :accessor foreign-slot-definition-setter)))
362
363
364;;; Use the foreign slot metaclasses if the slot has a :FOREIGN-TYPE attribute
365;; 
366
367(defmethod direct-slot-definition-class ((class objc:objc-class-object)
368                                         &rest initargs)
369  (if (getf initargs :foreign-type)
370    (find-class 'foreign-direct-slot-definition)
371    (find-class 'standard-direct-slot-definition)))
372
373(defmethod effective-slot-definition-class ((class objc:objc-class-object)
374                                            &rest initargs)
375  (if (getf initargs :foreign-type)
376    (find-class 'foreign-effective-slot-definition)
377    (find-class 'standard-effective-slot-definition)))
378
379
380(defun set-objc-foreign-direct-slot-offsets (dslotds bit-offset)
381  (dolist (d dslotds)
382    (let* ((ftype (foreign-slot-definition-foreign-type d))
383           (type-alignment (progn (ensure-foreign-type-bits ftype)
384                                  (foreign-type-alignment ftype))))
385      (setf (foreign-direct-slot-definition-bit-offset d)
386            (setq bit-offset
387                  (align-offset bit-offset type-alignment)))
388      (setq bit-offset (+ bit-offset (foreign-type-bits ftype))))))
389
390(defmethod (setf class-direct-slots) :before (dslotds (class objc::objc-class))
391  #-apple-objc-2.0
392  (let* ((foreign-dslotds
393          (loop for d in dslotds
394                when (typep d 'foreign-direct-slot-definition)
395                collect d))
396         (bit-offset (dolist (c (class-direct-superclasses class) 0)
397                       (when (typep c 'objc::objc-class)
398                         (return
399                           (ash (%objc-class-instance-size c)
400                                3))))))
401    (unless
402        (dolist (d foreign-dslotds t)
403          (if (not (foreign-direct-slot-definition-bit-offset d))
404            (return nil)))
405      (set-objc-foreign-direct-slot-offsets foreign-dslotds bit-offset)))
406  #+apple-objc-2.0
407  ;; Add ivars for each foreign direct slot, then ask the runtime for
408  ;; the ivar's byte offset.  (Note that the ObjC 2.0 ivar initialization
409  ;; protocol doesn't seem to offer support for bitfield-valued ivars.)
410  (dolist (dslotd dslotds)
411    (when (typep dslotd 'foreign-direct-slot-definition)
412      (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd)))
413             (type (foreign-slot-definition-foreign-type dslotd))
414             (encoding (progn
415                         (ensure-foreign-type-bits type)
416                         (encode-objc-type type)))
417             (size (ceiling (foreign-type-bits type) 8))
418             (align (round (log (ceiling (foreign-type-alignment type) 8) 2))))
419        (with-cstrs ((name string)
420                     (encoding encoding))
421          (#_class_addIvar class name size align encoding)
422          (with-macptrs ((ivar (#_class_getInstanceVariable class name)))
423              (unless (%null-ptr-p ivar)
424                (let* ((offset (#_ivar_getOffset ivar)))
425                  (setf (foreign-direct-slot-definition-bit-offset dslotd)
426                        (ash offset 3))))))))))
427
428                                               
429
430(defun lisp-defined-slot-name-to-objc-slot-name (lisp-name)
431  (lisp-to-objc-message (list lisp-name)))
432
433;;; This is only going to be called on a class created by the user;
434;;; each foreign direct slotd's offset field should already have been
435;;; set to the slot's bit offset.
436#-apple-objc-2.0
437(defun %make-objc-ivars (class)
438  (let* ((start-offset (superclass-instance-size class))
439         (foreign-dslotds (loop for s in (class-direct-slots class)
440                                when (typep s 'foreign-direct-slot-definition)
441                                collect s)))
442    (if (null foreign-dslotds)
443      (values (%null-ptr) start-offset)
444      (let* ((n (length foreign-dslotds))
445             (offset start-offset)
446             (ivars (malloc (+ 4 (* n (%foreign-type-or-record-size
447                                       :objc_ivar :bytes))))))
448      (setf (pref ivars :objc_ivar_list.ivar_count) n)
449      (do* ((l foreign-dslotds (cdr l))
450            (dslotd (car l) (car l))
451            (ivar (pref ivars :objc_ivar_list.ivar_list)
452                  (%inc-ptr ivar (%foreign-type-or-record-size
453                                 :objc_ivar :bytes))))
454           ((null l) (values ivars (ash (align-offset offset 32) 3)))
455        (let* ((string (lisp-defined-slot-name-to-objc-slot-name (slot-definition-name dslotd)))
456               (type (foreign-slot-definition-foreign-type dslotd))
457               (encoding (progn
458                           (ensure-foreign-type-bits type)
459                           (encode-objc-type type))))
460          (setq offset (foreign-direct-slot-definition-bit-offset dslotd))
461          (setf (pref ivar :objc_ivar.ivar_name) (make-cstring string)
462                (pref ivar :objc_ivar.ivar_type) (make-cstring encoding)
463                (pref ivar :objc_ivar.ivar_offset) (ash offset -3))
464          (incf offset (foreign-type-bits type))))))))
465 
466 
467
468(defun %objc-ivar-offset-in-class (name c)
469  ;; If C is a non-null ObjC class that contains an instance variable
470  ;; named NAME, return that instance variable's offset,  else return
471  ;; NIL.
472  #+apple-objc-2.0
473  (with-cstrs ((name name))
474    (with-macptrs ((ivar (#_class_getInstanceVariable c name)))
475      (unless (%null-ptr-p ivar)
476        (#_ivar_getOffset ivar))))
477  #-apple-objc-2.0
478  (when (objc-class-p c)
479    (with-macptrs ((ivars (pref c :objc_class.ivars)))
480      (unless (%null-ptr-p ivars)
481        (loop with n = (pref ivars :objc_ivar_list.ivar_count)
482              for i from 1 to n
483              for ivar = (pref ivars :objc_ivar_list.ivar_list) 
484                  then (%inc-ptr ivar (record-length :objc_ivar))
485              when (string= name (%get-cstring (pref ivar :objc_ivar.ivar_name)))
486                do (return-from %objc-ivar-offset-in-class (pref ivar :objc_ivar.ivar_offset)))))))
487
488(defun %objc-ivar-offset (name c)
489  (labels ((locate-objc-slot (name class)
490             (unless (%null-ptr-p class)
491                 (or (%objc-ivar-offset-in-class name class)
492                     (with-macptrs ((super #+apple-objc-2.0
493                                           (#_class_getSuperclass class)
494                                           #-apple-objc-2.0
495                                           (pref class :objc_class.super_class)))
496                       (unless (or (%null-ptr-p super) (eql super class))
497                         (locate-objc-slot name super)))))))
498    (when (objc-class-p c)
499      (or (locate-objc-slot name c)
500          (error "No ObjC instance variable named ~S in ~S" name c)))))
501
502;;; Maintain the class wrapper of an ObjC class or metaclass.
503
504(defmethod (setf class-own-wrapper) :after (wrapper (class objc::objc-metaclass))
505  (setf (id->objc-metaclass-wrapper (objc-metaclass-id class)) wrapper))
506
507(defmethod (setf class-own-wrapper) :after (wrapper (class objc::objc-class))
508  (setf (id->objc-class-wrapper (objc-class-id class)) wrapper))
509
510;;; Return the getter and setter functions for a foreign slot
511;;; NOTE: Should be changed to use FOREIGN-TYPE-TO-REPRESENTATION-TYPE
512
513(defun compute-foreign-slot-accessors (eslotd)
514  (let* ((ftype (foreign-slot-definition-foreign-type eslotd)))
515    (etypecase ftype
516      (foreign-integer-type
517       (let* ((bits (foreign-integer-type-bits ftype))
518              (align (foreign-integer-type-alignment ftype))
519              (signed (foreign-integer-type-signed ftype)))
520         (if (= bits align)
521           (ecase bits
522             (1 (values #'%get-bit #'%set-bit))
523             (8 (values (if signed #'%get-signed-byte #'%get-unsigned-byte)
524                        #'%set-byte))
525             (16 (values (if signed #'%get-signed-word #'%get-unsigned-word)
526                         #'%set-word))
527             (32 (values (if signed #'%get-signed-long #'%get-unsigned-long)
528                         #'%set-long))
529             (64 (if signed
530                   (values #'%%get-signed-longlong #'%%set-signed-longlong)
531                   (values #'%%get-unsigned-longlong #'%%set-unsigned-longlong))))
532           (values #'(lambda (ptr offset)
533                       (%get-bitfield ptr offset bits))
534                   #'(lambda (ptr offset new)
535                       (setf (%get-bitfield ptr offset bits) new))))))
536      (foreign-double-float-type
537       (values #'%get-double-float #'%set-double-float))
538      (foreign-single-float-type
539       (values #'%get-single-float #'%set-single-float))
540      (foreign-pointer-type
541       ;; If we're pointing to a structure whose first field is
542       ;; a pointer to a structure named :OBJC_CLASS, we're of
543       ;; type :ID and can (fairly) safely use %GET-PTR.
544       ;; Otherwise, reference the field as a raw  macptr.
545       (let* ((to (foreign-pointer-type-to ftype)))
546         (if
547           (and (typep to 'foreign-record-type)
548                (eq :struct (foreign-record-type-kind to))
549                (progn
550                  (ensure-foreign-type-bits to)
551                  (let* ((first-field (car (foreign-record-type-fields to)))
552                         (first-field-type
553                          (if first-field
554                            (foreign-record-field-type first-field))))
555                    (and (typep first-field-type 'foreign-pointer-type)
556                         (let* ((first-to (foreign-pointer-type-to
557                                           first-field-type)))
558                           (and (typep first-to 'foreign-record-type)
559                                (eq :struct
560                                    (foreign-record-type-kind first-to))
561                                (eq :objc_class
562                                    (foreign-record-type-name first-to))))))))
563           (values #'%get-ptr #'%set-ptr)
564           (values #'(lambda (ptr offset)
565                       (let* ((p (%null-ptr)))
566                         (%set-macptr-domain p 1)
567                         (%setf-macptr p (%get-ptr ptr offset))))
568                   #'%set-ptr))))
569      (foreign-mem-block-type
570       (let* ((nbytes (%foreign-type-or-record-size ftype :bytes)))
571         (values #'%inc-ptr #'(lambda (pointer offset new)
572                                (setf (%composite-pointer-ref
573                                       nbytes
574                                       pointer
575                                       offset)
576                                      new))))))))
577   
578
579
580;;; Shadow SLOT-CLASS's COMPUTE-EFFECTIVE-SLOT-DEFINITION with a
581;;; method for OBJC-CLASSes that sets up foreign slot info.
582
583(defmethod compute-effective-slot-definition :around ((class objc:objc-class-object)
584                                                      name
585                                                      direct-slots)
586  (let* ((first (first direct-slots)))
587    (if (not (typep first 'foreign-direct-slot-definition))
588      (call-next-method)
589      (let* ((initer (dolist (s direct-slots)
590                       (when (%slot-definition-initfunction s)
591                         (return s))))
592             (documentor (dolist (s direct-slots)
593                           (when (%slot-definition-documentation s)
594                             (return s))))
595             (initargs (let* ((initargs nil))
596                         (dolist (dslot direct-slots initargs)
597                           (dolist (dslot-arg (%slot-definition-initargs  dslot))
598                             (pushnew dslot-arg initargs :test #'eq)))))
599             (eslotd
600               (make-effective-slot-definition
601                class
602                :name name
603                :allocation :instance
604                :type (or (%slot-definition-type first) t)
605                :documentation (when documentor (nth-value
606                                      1
607                                      (%slot-definition-documentation
608                                       documentor)))
609                :class (%slot-definition-class first)
610                :initargs initargs
611                :initfunction (if initer
612                                (%slot-definition-initfunction initer))
613                :initform (if initer (%slot-definition-initform initer))
614                :foreign-type (foreign-slot-definition-foreign-type first))))
615      (multiple-value-bind (getter setter) (compute-foreign-slot-accessors eslotd)
616        (setf (foreign-slot-definition-getter eslotd) getter)
617        (setf (foreign-slot-definition-setter eslotd) setter))
618      eslotd))))
619
620(defun bit-offset-to-location (bit-offset foreign-type)
621  (ensure-foreign-type-bits foreign-type)
622  (let* ((bits (foreign-type-bits foreign-type)))
623    (if (or (= bits 1)
624            (not (= bits (foreign-type-alignment foreign-type))))
625      bit-offset
626      (ash bit-offset -3))))
627
628;;; Determine the location of each slot
629;;; An effective slot's location is
630;;; a) a function of the class's origin (superclass-instance-size)
631;;;    and the corresponding direct class's offset, if it's defined in the
632;;;    class (has a corresponding direct-slot-definition in the class)
633;;; b) Exactly the same as the superclass's version's location, because
634;;;    of single inheritance.
635
636(defun determine-foreign-slot-location (class slot-name)
637  (or
638   (dolist (d (class-direct-slots class))
639     (when (and (eq slot-name (slot-definition-name d))
640                (typep d 'foreign-direct-slot-definition))
641       (return (bit-offset-to-location
642                (foreign-direct-slot-definition-bit-offset d)
643                (foreign-slot-definition-foreign-type d )))))
644   (dolist (super (class-direct-superclasses class))
645     (when (typep super 'objc:objc-class) ; can be at most 1
646       (let* ((e (find slot-name (class-slots super) :key #'slot-definition-name)))
647         (when e (return (slot-definition-location e))))))
648   (error "Can't find slot definition for ~s in ~s" slot-name class)))
649         
650
651(defmethod compute-slots :around ((class objc:objc-class-object))
652  (flet ((foreign-slot-p (s) (typep s 'foreign-effective-slot-definition)))
653    (let* ((cpl (%class-precedence-list class))
654           (slots (call-next-method))
655           (instance-slots 
656            (remove-if #'foreign-slot-p 
657                       (remove :class slots :key #'%slot-definition-allocation)))
658           (class-slots (remove :instance slots :key #'%slot-definition-allocation))
659           (foreign-slots (remove-if-not #'foreign-slot-p slots)))
660      (setq instance-slots
661            (sort-effective-instance-slotds instance-slots class cpl))
662      (when *objc-clos-debug*
663        (format t "Instance slots: ~S~%Class Slots: ~S~%Foreign Slots: ~S~%"
664                instance-slots class-slots foreign-slots))
665      (loop for islot in instance-slots
666            for loc = 1 then (1+ loc)
667            do (setf (%slot-definition-location islot) loc))
668      (dolist (cslot class-slots)
669        (setf (%slot-definition-location cslot)
670              (assoc (%slot-definition-name cslot)
671                     (%class-get (%slot-definition-class cslot) :class-slots)
672                     :test #'eq)))
673      (dolist (fslot foreign-slots)
674        (setf (%slot-definition-location fslot)
675              (determine-foreign-slot-location
676               class
677               (%slot-definition-name fslot))))
678      (append instance-slots class-slots foreign-slots))))
679
680
681;;; Accessing foreign slots
682
683(defmethod slot-boundp-using-class ((class objc:objc-class-object)
684                                    instance
685                                    (slotd foreign-effective-slot-definition))
686  (declare (ignore class instance slotd))
687  ;; foreign slots are always bound
688  t)
689
690(defmethod slot-makunbound-using-class ((class objc:objc-class-object)
691                                        instance
692                                        (slotd foreign-effective-slot-definition))
693  (declare (ignore instance))
694  (error "Foreign slots cannot be unbound: ~S" (slot-definition-name slotd)))
695
696(defmethod slot-value-using-class ((class objc:objc-class-object)
697                                   instance
698                                   (slotd foreign-effective-slot-definition))
699  (funcall (foreign-slot-definition-getter slotd)
700           instance
701           (slot-definition-location slotd)))
702
703(defmethod (setf slot-value-using-class) (value
704                                          (class objc:objc-class-object)
705                                          instance
706                                          (slotd foreign-effective-slot-definition))
707  (funcall (foreign-slot-definition-setter slotd)
708           instance
709           (slot-definition-location slotd)
710           value))
711
712
713;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
714;;;;            Instance Allocation and Initialization Protocols            ;;;;
715;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
716
717(defmethod make-instance ((class objc:objc-class-object) &rest initargs)
718  (let ((instance (apply #'allocate-instance class initargs)))
719    (apply #'initialize-instance instance initargs)))
720
721
722(defun remove-slot-initargs (class initargs)
723  (let* ((slot-initargs (class-slot-initargs class))) ; cache this, maybe
724    (loop for l = initargs then (cddr l)
725          when (null l) do (return-from remove-slot-initargs new-initargs)
726          unless (member (first l)  slot-initargs :test #'eq)
727            append (list (first l) (second l))  into new-initargs)))
728
729(defun create-foreign-instance-slot-vector (class)
730  (let* ((max 0))
731    (dolist (slotd (class-slots class)
732             (unless (zerop max)
733               (allocate-typed-vector :slot-vector (1+ max) (%slot-unbound-marker))))
734      (when (typep slotd 'standard-effective-slot-definition)
735        (let* ((loc (slot-definition-location slotd)))
736          (if (> loc max)
737            (setq max loc)))))))
738
739               
740                                         
741(defmethod allocate-instance ((class objc:objc-class) &rest initargs &key &allow-other-keys)
742  (unless (class-finalized-p class)
743    (finalize-inheritance class))
744  (let* ((instance
745          (multiple-value-bind (ks vs) (keys-and-vals (remove-slot-initargs
746                                                       class
747                                                       initargs))
748            (send-objc-init-message (allocate-objc-object class) ks vs))))
749    (unless (%null-ptr-p instance)
750      (let* ((slot-vector (create-foreign-instance-slot-vector class)))
751        (when slot-vector
752          (let* ((raw-ptr (raw-macptr-for-instance instance)))
753            (setf (slot-vector.instance slot-vector) raw-ptr)
754            (setf (gethash raw-ptr *objc-object-slot-vectors*) slot-vector)
755            (register-canonical-objc-instance instance raw-ptr)))))
756    instance))
757
758(defmethod terminate ((instance objc:objc-object))
759  (objc-message-send instance "release"))
760
761
762
763(defmethod initialize-instance ((instance objc:objc-object) &rest initargs)
764  (apply #'shared-initialize instance t initargs))
765
766(defmethod reinitialize-instance ((instance objc:objc-object) &rest initargs)
767  (apply #'shared-initialize instance nil initargs))
768
769(defmethod initialize-instance :after ((class objc:objc-class) &rest initargs)
770  (declare (ignore initargs))
771  (unless (slot-value class 'foreign)
772    #-apple-objc-2.0
773    (multiple-value-bind (ivars instance-size)
774        (%make-objc-ivars class)
775      (%add-objc-class class ivars instance-size))
776    #+apple-objc-2.0
777    (%add-objc-class class)))
778
779(defmethod shared-initialize ((instance objc:objc-object) slot-names 
780                              &rest initargs)
781  (let ((class (class-of instance)))
782    ;; Initialize CLOS slots
783    (dolist (slotd (class-slots class))
784      (when (not (typep slotd 'foreign-effective-slot-definition)) ; For now
785        (let ((sname (slot-definition-name slotd))
786              (slot-type (slot-definition-type slotd))
787              (typepred (slot-value slotd 'type-predicate))
788              (initfunction (slot-definition-initfunction slotd)))
789          (multiple-value-bind (ignore newval foundp)
790                               (get-properties initargs
791                                               (slot-definition-initargs slotd))
792            (declare (ignore ignore))
793            (if foundp
794                (if (funcall typepred newval)
795                    (setf (slot-value instance sname) newval)
796                  (report-bad-arg newval slot-type))
797              (let* ((loc (slot-definition-location slotd))
798                     (curval (%standard-instance-instance-location-access
799                             instance loc)))
800                (when (and (or (eq slot-names t) 
801                               (member sname slot-names :test #'eq))
802                           (eq curval (%slot-unbound-marker))
803                           initfunction)
804                  (let ((newval (funcall initfunction)))
805                    (unless (funcall typepred newval)
806                      (report-bad-arg newval slot-type))
807                    (setf (%standard-instance-instance-location-access
808                           instance loc)
809                          newval)))))))))
810    instance))
811
812(defmethod shared-initialize :after ((spec foreign-effective-slot-definition)
813                                     slot-names
814                                     &key &allow-other-keys)
815  (declare (ignore slot-names))
816  (setf (slot-value spec 'type-predicate) #'true))
817
818;;; The CLASS-OF an existing OBJC:OBJC-CLASS is an OBJC:OBJC-METACLASS,
819;;; but not necessarily the one specified as a :metaclass option to
820;;; DEFCLASS or ENSURE-CLASS.  Allow an existing class to be reinitialized,
821;;; as long as the specified :metaclass and the class's own class have
822;;; the same metaclass and specified metaclass is a root class.
823
824(defmethod ensure-class-using-class ((class objc:objc-class)
825                                     name
826                                     &rest keys &key)
827  (multiple-value-bind (metaclass initargs)
828      (ensure-class-metaclass-and-initargs class keys)
829    (let* ((existing-metaclass (class-of class)))
830      (if (and (eq (class-of metaclass)
831                   (class-of existing-metaclass))
832               ;; A root metaclass has the corresponding class as
833               ;; its superclass, and that class has no superclass.
834               (with-macptrs ((super #+apple-objc-2.0
835                                     (#_class_getSuperclass metaclass)
836                                     #-apple-objc-2.0
837                                     (pref metaclass :objc_class.super_class)))
838                 (and (not (%null-ptr-p super))
839                      (not (%objc-metaclass-p super))
840                      (%null-ptr-p
841                       #+apple-objc-2.0
842                       (#_class_getSuperclass super)
843                       #-apple-objc-2.0
844                       (pref super :objc_class.super_class)))))
845        ;; Whew! it's ok to reinitialize the class.
846        (progn
847          (apply #'reinitialize-instance class initargs)
848          (setf (find-class name) class))
849        (error "Can't change metaclass of ~s to ~s." class metaclass)))))
850
851 
852
853;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
854;;;;              Class Definition and Finalization Protocols               ;;;;
855;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
856
857;;; Create the ObjC class/metaclass pair and dress it up in its minimal CLOS garb
858;;; This currently requires that exactly one of DIRECT-SUPERCLASSES be a
859;;; already existing subclass of OBJC:OBJC-CLASS
860
861(defun compute-objc-variable-name (sym)
862  (let* ((pname (string sym))
863         (first-alpha (position-if #'alpha-char-p pname)))
864    (string-downcase
865     (apply #'string-cat 
866            (mapcar #'string-capitalize (split-if-char #\- pname :elide)))
867     :end (if first-alpha (1+ first-alpha) 1))))
868
869(defmethod allocate-instance ((metaclass objc:objc-metaclass) 
870                              &key name direct-superclasses
871                              &allow-other-keys)
872  (let ((superclass
873         (loop for s in direct-superclasses
874               when (typep s 'objc:objc-class)
875                 collect s into objc-supers
876               finally 
877               (if (= (length objc-supers) 1)
878                   (return (first objc-supers))
879                 (error "Exactly one OBJC:OBJC-CLASS must appear in ~S, found ~S" 
880                        direct-superclasses
881                        (length objc-supers))))))
882    (%allocate-objc-class name superclass)))
883
884(defmethod shared-initialize ((class objc:objc-class-object) slot-names &rest initargs)
885  (%shared-initialize class slot-names initargs))
886
887(defmethod validate-superclass ((c1 objc:objc-class) (c2 objc:objc-class))
888  t)
889
890(defmethod make-instances-obsolete ((class objc:objc-class))
891  class)
892
893;;; Reader/writer methods for instances of OBJC:OBJC-CLASS
894(defmethod reader-method-class ((class objc:objc-class)
895                                (dslotd direct-slot-definition)
896                                &rest initargs)
897  (declare (ignore initargs))
898  (find-class 'standard-reader-method))
899
900(defmethod writer-method-class ((class objc:objc-class)
901                                (dslotd direct-slot-definition)
902                                &rest initargs)
903  (declare (ignore initargs))
904  (find-class 'standard-writer-method))
905
906
907;;; This (interesting) code has never been enabled, and is (slightly)
908;;; broken by the new (lazy, declaration-based) implementation of SEND
909;;; and friends.
910;;; We probably want to un-break this (and figure out how to define
911;;; ObjC gf's in the new world), and some of the code for compiling
912;;; arbitrary message sends may be useful in other contexts.
913
914#+objc-generic-functions
915(progn
916;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
917;;;;                 Generic Function and Method  Protocols                 ;;;;
918;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
919
920;;; The classes of ObjC generic functions and methods
921
922(defclass objc-generic-function (standard-generic-function) 
923  ()
924  (:metaclass funcallable-standard-class))
925
926(defclass objc-method (standard-method) ())
927
928
929;;; Return the generic function name, lambda list and keywords corresponding
930;;; to a given ObjC MSG
931
932(defun gfify (msg)
933  (let* ((mcomps (split-if-char #\: msg :elide))
934         (ncolons (count #\: msg))
935         (prefix (if (zerop ncolons) "@" "")))
936    (values (compute-lisp-name 
937             (if (zerop ncolons)
938                 (string-cat prefix (first mcomps))
939               (first mcomps))
940             (find-package "NS"))
941            (if (zerop ncolons) '(%self) '(%self %arg &key))
942            (mapcar #'compute-lisp-name (rest mcomps)))))
943
944
945;;; Special dcode for ObjC generic functions
946;;; Currently, the list of keywords is used as the qualifier for an ObjC method
947;;; This dcode just scans the list of methods looking for one whose qualifer
948;;; matches the keywords in this call
949
950(defun %%objc-dcode (dt args)
951  (flet ((invoke-method (largs)
952           (multiple-value-bind (keys vals) (keys-and-vals (cddr largs))
953             (declare (ignore vals))
954             (dolist (m (%gf-dispatch-table-methods dt))
955               (when (equal (method-qualifiers m) keys)
956                 (return-from %%objc-dcode (apply (method-function m) largs))))
957             (apply #'no-applicable-method (%gf-dispatch-table-gf dt) largs))))
958    ;; If only one arg is present, ARGS is apparently not encoded
959    (if (numberp args)
960        (with-list-from-lexpr (l args) (invoke-method l))
961      (invoke-method (list args)))))
962
963
964;;; Ensure that the generic function corresponding to MSG exists
965
966(defun ensure-objc-generic-function (msg)
967  (cond 
968   ((null (message-descriptors msg))
969    (error "Unknown ObjC message: ~S" msg))
970   ((troublesome-message-p msg) nil)
971   (t
972    (multiple-value-bind (gf-name lambda-list) (gfify msg)         
973      (let ((gf (ensure-generic-function
974                 gf-name
975                 :lambda-list lambda-list
976                 :generic-function-class (find-class 'objc-generic-function)
977                 :method-class (find-class 'objc-method))))
978        (setf (%gf-dcode gf) #'%%objc-dcode)
979        gf)))))
980
981
982;;; Create the method function corresponding to the given ObjC MSG
983
984(defun make-objc-method-function (msg lambda-list keys)
985  (let ((msgdescs (message-descriptors msg)))
986    (compile 
987     nil
988     (if (= (length msgdescs) 1)
989         ;; The type signature is unique
990         `(lambda ,lambda-list
991            ,(build-message-send 
992              msg (msg-desc-type-signature (first msgdescs)) keys))
993       ;; The type signature is ambiguous
994       `(lambda ,lambda-list
995          (cond
996           ,@(loop for md in msgdescs
997                  collect
998                  `((or 
999                     ,@(loop for c in (msg-desc-classes md)
1000                             collect
1001                             `(typep %self ',(class-name c))))
1002                    (locally
1003                      (declare (,(class-name (first (msg-desc-classes md)))
1004                                %self))
1005                      ,(build-message-send 
1006                        msg (msg-desc-type-signature md) keys))))))))))
1007
1008
1009;;; Build the message-sending code for the given message with the given
1010;;; type signature and keys
1011
1012(defun build-message-send (msg tsig keys)
1013  (let* ((rvars nil)
1014         (args (if (zerop (count #\: msg))
1015                   nil
1016                 (loop 
1017                  for a in (cons '%arg keys)
1018                  for ftype in (rest tsig)
1019                  for r/s-assoc = (coerceable-foreign-record-p ftype)
1020                  for sname = (gensym)
1021                  if r/s-assoc
1022                    do (push (list sname (fudge-objc-type ftype)) rvars)
1023                    and collect
1024                    (generate-structure-to-foreign-record-copier-form 
1025                     (record-structure-association-structure-name r/s-assoc)
1026                     (record-structure-association-record-name r/s-assoc)
1027                     :struct-name a :record-name sname)
1028                  else collect a))))
1029       (if (requires-stret-p (first tsig))
1030           ;; STRET message send
1031           (let ((r (gensym)))
1032             `(rlet ((,r ,(fudge-objc-type (first tsig))) ,@rvars)
1033                (send/stret ,r %self ,msg ,@args)
1034                ,(create-structure-from-record-form r (cadar tsig))))
1035         ;; Normal message send
1036         `(rlet ,rvars
1037            (send %self ,msg ,@args)))))
1038
1039
1040;;; Ensure that the method corresponding to CLASS's method for MSG exists
1041
1042(defun ensure-objc-method (msg)
1043  (cond 
1044   ((null (message-descriptors msg))
1045    (error "Unknown ObjC message: ~S" msg))
1046   ((troublesome-message-p msg) nil)
1047   (t
1048    (flet ((keywordify (sym)
1049             (intern (string sym) (find-package 'keyword))))
1050      (multiple-value-bind (gf-name lambda-list keys) (gfify msg)
1051        (let* ((gf (ensure-objc-generic-function msg))
1052               (lambda-list (append lambda-list keys))
1053               (m
1054                (ensure-method
1055                 gf-name
1056                 nil
1057                 :function (make-objc-method-function msg lambda-list keys)
1058                 :qualifiers (mapcar #'keywordify keys)
1059                 :lambda-list lambda-list)))
1060          (setf (%gf-dcode gf) #'%%objc-dcode)
1061          m))))))
1062
1063
1064;;; Generate ObjC methods for all messages in *TYPE-SIGNATURE-TABLE*
1065
1066(defun define-all-objc-methods ()
1067  (declare (special *type-signature-table*))
1068  (maphash #'(lambda (msg ignore) 
1069               (declare (ignore ignore))
1070               (ensure-objc-method msg))
1071           *type-signature-table*))
1072
1073
1074;;; Lisp structures analogous to common Cocoa records
1075
1076(defstruct (ns-range (:constructor make-ns-range (location length)))
1077  location
1078  length)
1079
1080(defun ns-make-range (loc len)
1081  (make-ns-range loc len))
1082
1083(defstruct (ns-point (:constructor make-ns-point (x y)))
1084  x
1085  y)
1086
1087(defun ns-make-point (x y)
1088  (make-ns-point (coerce x 'single-float) (coerce y 'single-float)))
1089
1090(defstruct (ns-size (:constructor make-ns-size (width height)))
1091  width
1092  height)
1093
1094(defun ns-make-size (w h)
1095  (make-ns-size 
1096   (coerce w 'single-float) 
1097   (coerce h 'single-float)))
1098
1099;;; Note that this is linear: four fields, rather than an ns-point
1100;;; and an ns-size.
1101(defstruct (ns-rect
1102             (:constructor make-ns-rect
1103                           (origin.x origin.y size.width size.height)))
1104  origin.x
1105  origin.y
1106  size.width
1107  size.height)
1108
1109(defun ns-make-rect (ox oy sw sh)
1110  (make-ns-rect
1111   (coerce ox 'single-float)
1112   (coerce oy 'single-float)
1113   (coerce sw 'single-float)
1114   (coerce sh 'single-float)))
1115
1116(defstruct (ns-decimal
1117            (:constructor make-ns-decimal
1118                          (_exponent _length _is-negative _is-compact _reserved _mantissa)))
1119  _exponent
1120  _length
1121  _is-negative
1122  _is-compact
1123  _reserved
1124  _mantissa)
1125
1126;;; Also linear
1127(defstruct (cg-rect
1128            (:constructor make-cg-rect
1129                          (origin.x origin.y size.width size.height)))
1130  origin.x
1131  origin.y
1132  size.width
1133  size.height)
1134
1135(defstruct (ns-affine-transform-struct
1136            (:constructor make-ns-affine-transform-struct
1137                          (m11 m12 m21 m22 tx ty)))
1138  m11 m12 m21 m22 tx ty)
1139
1140
1141(defun generate-foreign-record-to-structure-copier-form (record-type-name structure-class-name &key (struct-name (gensym)) (record-name (gensym)))
1142  (let* ((slot-names (mapcar #'slot-definition-name (class-slots (find-class structure-class-name))))
1143         (record-type (%foreign-type-or-record record-type-name))
1144         (accessor-names (foreign-record-accessor-names record-type)))
1145    (unless (eq (length slot-names) (length accessor-names))
1146      (error "Slot names ~s don't match record accessors ~s"
1147             slot-names accessor-names))
1148    (let* ((body (mapcar #'(lambda (slot-name accessor)
1149                             `(setf (slot-value ,struct-name ',slot-name)
1150                               ,(%foreign-access-form record-name
1151                                                      record-type
1152                                                      0
1153                                                      accessor)))
1154                         slot-names accessor-names)))
1155      `(progn ,@body ,struct-name))))
1156
1157(defun generate-structure-to-foreign-record-copier-form
1158    (structure-class-name record-type-name
1159                          &key
1160                          (struct-name (gensym))
1161                          (record-name (gensym)))
1162  (let* ((slot-names (mapcar #'slot-definition-name (class-slots (find-class structure-class-name))))
1163         (record-type (%foreign-type-or-record record-type-name))
1164         (accessor-names (foreign-record-accessor-names record-type)))
1165    (unless (eq (length slot-names) (length accessor-names))
1166      (error "Slot names ~s don't match record accessors ~s"
1167             slot-names accessor-names))
1168    (let* ((body (mapcar #'(lambda (slot-name accessor)
1169                             `(setf ,(%foreign-access-form record-name
1170                                                           record-type
1171                                                           0
1172                                                           accessor)
1173                               (slot-value ,struct-name ',slot-name)))
1174                         slot-names accessor-names)))
1175      `(progn ,@body ,record-name))))
1176
1177(defun generate-foreign-record-to-structure-creator-form
1178    (record-type-name constructor-name &key (record-name (gensym)))
1179  (let* ((record-type (%foreign-type-or-record record-type-name))
1180         (accessor-names (foreign-record-accessor-names record-type))
1181         (args (mapcar #'(lambda (accessor)
1182                           (%foreign-access-form record-name
1183                                                 record-type
1184                                                 0
1185                                                 accessor))
1186                       accessor-names)))
1187    `(,constructor-name ,@args)))
1188
1189           
1190(defstruct record-structure-association
1191  record-name
1192  structure-name
1193  structure-constructor-name)
1194
1195(defparameter *record-structure-associations* ())
1196
1197(defun record-structure-association-from-record-name (r)
1198  (find r *record-structure-associations* :key #'record-structure-association-record-name))
1199
1200(defun need-record-structure-association-from-record-name (r)
1201  (or (record-structure-association-from-record-name r)
1202      (error "No lisp structure associated with foreign record named ~s" r)))
1203 
1204(defun record-structure-association-from-structure-name (r)
1205  (find r *record-structure-associations* :key #'record-structure-association-structure-name))
1206
1207(defun associate-record-with-structure (record-name structure-name constructor-name)
1208  (let* ((already-r (record-structure-association-from-record-name record-name))
1209         (already-s (record-structure-association-from-structure-name structure-name))
1210         (already (or already-r already-s))
1211         (different (not (eq already-r already-s))))
1212    (if already
1213      (if different
1214        (if already-r
1215          (error "~&Record named ~s is already associated with structure named ~s"
1216                 (record-structure-association-record-name already-r)
1217                 (record-structure-association-structure-name already-r))
1218          (if already-s
1219            (error "~&Structure named ~s is already associated with record named ~s"
1220                   (record-structure-association-structure-name already-s)
1221                   (record-structure-association-record-name already-s))))
1222        (setf (record-structure-association-structure-constructor-name already)
1223              constructor-name))
1224      (push (make-record-structure-association
1225             :record-name record-name
1226             :structure-name structure-name
1227             :structure-constructor-name constructor-name)
1228            *record-structure-associations*))
1229    t))
1230
1231(defun create-structure-from-record-form (var record-type)
1232  (let* ((a (need-record-structure-association-from-record-name
1233             record-type))
1234         (constructor
1235          (record-structure-association-structure-constructor-name a)))
1236    (generate-foreign-record-to-structure-creator-form
1237     record-type constructor :record-name var)))
1238
1239(defun coerceable-foreign-record-p (ftype)
1240  (and (consp ftype) 
1241       (eq (first ftype) :struct) 
1242       (find (second ftype) *record-structure-associations*
1243             :key #'record-structure-association-record-name)))
1244   
1245(associate-record-with-structure :_<NSR>ect 'ns-rect 'make-ns-rect)
1246(associate-record-with-structure :_<NSP>oint 'ns-point 'make-ns-point)
1247(associate-record-with-structure :_<NSS>ize 'ns-size 'make-ns-size)
1248(associate-record-with-structure :_<NSR>ange 'ns-range 'make-ns-range)
1249(associate-record-with-structure :<NSD>ecimal 'ns-decimal 'make-ns-decimal)
1250(associate-record-with-structure :<CGR>ect 'cg-rect 'make-cg-rect)
1251(associate-record-with-structure :_<NSA>ffine<T>ransform<S>truct 
1252                                 'ns-affine-transform-struct 
1253                                 'make-ns-affine-transform-struct)
1254) ; #+objc-generic-functions
Note: See TracBrowser for help on using the repository browser.