source: branches/objc-gf/ccl/examples/objc-clos.lisp @ 6078

Last change on this file since 6078 was 6078, checked in by gb, 13 years ago

Package defs moved elsewhere.

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