source: trunk/source/objc-bridge/objc-runtime.lisp @ 11589

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

Try to get variadic method calls working on DarwinPPC64. The IDE comes up
on PPC64 and seeme to work. (It actually used to work in early Leopard
prereleases ...)

Still need to be able to catch NSExceptions in lisp (need magic annotations
in .SPffcall and friends), and need to test the stuff that maps lisp
exceptions to NSExceptions.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 115.0 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2002-2003 Clozure Associates
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
18(in-package "CCL")
19
20
21;;; Utilities for interacting with the Apple/GNU Objective-C runtime
22;;; systems.
23
24(eval-when (:compile-toplevel :load-toplevel :execute)
25  #+darwin-target (pushnew :apple-objc *features*)
26  #+(and darwin-target 64-bit-target) (pushnew :apple-objc-2.0 *features*)
27  #-darwin-target (pushnew :gnu-objc *features*))
28
29
30(eval-when (:compile-toplevel :load-toplevel :execute)
31  (set-dispatch-macro-character
32   #\#
33   #\@
34   (nfunction
35    |objc-#@-reader|
36    (lambda (stream subchar numarg)
37      (declare (ignore subchar numarg))
38      (let* ((string (read stream)))
39        (unless *read-suppress*
40          (check-type string string)
41          `(@ ,string)))))))
42
43(eval-when (:compile-toplevel :execute)
44  #+apple-objc
45  (progn
46    (use-interface-dir :cocoa)
47    #+nomore
48    (use-interface-dir :carbon))        ; need :carbon for things in this file
49  #+gnu-objc
50  (use-interface-dir :gnustep))
51
52
53
54(eval-when (:compile-toplevel :load-toplevel :execute)
55  (require "OBJC-PACKAGE")
56  (require "NAME-TRANSLATION")
57  (require "OBJC-CLOS"))
58
59;;; NSInteger and NSUInteger probably belong here.
60;;; CGFloat not so much.
61
62#-apple-objc-2.0
63(progn
64  (def-foreign-type :<CGF>loat :float)
65  (def-foreign-type :<NSUI>nteger :unsigned)
66  (def-foreign-type :<NSI>nteger :signed)
67  )
68
69(defconstant +cgfloat-zero+
70  #+(and apple-objc-2.0 64-bit-target) 0.0d0
71  #-(and apple-objc-2.0 64-bit-target) 0.0f0)
72
73(deftype cgfloat ()
74  #+(and apple-objc-2.0 64-bit-target) 'double-float
75  #-(and apple-objc-2.0 64-bit-target) 'single-float)
76
77(deftype cg-float () 'cgfloat)
78
79(deftype nsuinteger ()
80  #+(and apple-objc-2.0 64-bit-target) '(unsigned-byte 64)
81  #-(and apple-objc-2.0 64-bit-target) '(unsigned-byte 32))
82
83(deftype nsinteger ()
84  #+(and apple-objc-2.0 64-bit-target) '(signed-byte 64)
85  #-(and apple-objc-2.0 64-bit-target) '(signed-byte 32))
86
87
88(defloadvar *NSApp* nil )
89
90;;; Apple ObjC 2.0 provides (#_objc_getProtocol name).  In other
91;;; runtimes, there doesn't seem to be any way to find a Protocol
92;;; object given its name.  We need to be able to ask at runtime
93;;; whether a given object conforms to a protocol in order to
94;;; know when a protocol method is ambiguous, at least when the
95;;; message contains ambiguous methods and some methods are protocol
96;;; methods
97(defvar *objc-protocols* (make-hash-table :test #'equal))
98
99
100(defstruct objc-protocol
101  name
102  address)
103
104
105(defun clear-objc-protocols ()
106  (maphash #'(lambda (name proto)
107               (declare (ignore name))
108               (setf (objc-protocol-address proto) nil))
109           *objc-protocols*))
110
111(defun lookup-objc-protocol (name)
112  (values (gethash name *objc-protocols*)))
113
114(defun ensure-objc-classptr-resolved (classptr)
115  #+apple-objc (declare (ignore classptr))
116  #+gnu-objc
117  (unless (logtest #$_CLS_RESOLV (pref classptr :objc_class.info))
118    (external-call "__objc_resolve_class_links" :void)))
119
120
121
122(defstruct private-objc-class-info
123  name
124  declared-ancestor)
125
126(defun compute-objc-direct-slots-from-info (info class)
127  (let* ((ns-package (find-package "NS")))
128    (mapcar #'(lambda (field)
129                (let* ((name (compute-lisp-name (unescape-foreign-name
130                                                 (foreign-record-field-name
131                                                  field))
132                                                ns-package))
133
134                       (type (foreign-record-field-type field))
135                       (offset (progn
136                                    (ensure-foreign-type-bits type)
137                                    (foreign-record-field-offset field))))
138                  (make-instance 'foreign-direct-slot-definition
139                                 :initfunction #'false
140                                 :initform nil
141                                 :name name
142                                 :foreign-type type
143                                 :class class
144                                 :bit-offset offset
145                                 :allocation :instance)))
146            (db-objc-class-info-ivars info))))
147
148
149(defun %ptr< (x y)
150  (< (the (unsigned-byte #+64-bit-target 64 #+32-bit-target 32)
151       (%ptr-to-int x))
152     (the (unsigned-byte #+64-bit-target 64 #+32-bit-target 32)
153       (%ptr-to-int Y))))
154
155(let* ((objc-class-map (make-hash-table :test #'eql :size 1024))
156       (objc-metaclass-map (make-hash-table :test #'eql :size 1024))
157       ;;; These are NOT lisp classes; we mostly want to keep track
158       ;;; of them so that we can pretend that instances of them
159       ;;; are instances of some known (declared) superclass.
160       (private-objc-classes (make-hash-table :test #'eql :size 2048))
161       (objc-class-lock (make-lock))
162       (next-objc-class-id 0)
163       (next-objc-metaclass-id 0)
164       (class-table-size 1024)
165       (c (make-array class-table-size))
166       (m (make-array class-table-size))
167       (cw (make-array class-table-size :initial-element nil))
168       (mw (make-array class-table-size :initial-element nil))
169       (csv (make-array class-table-size))
170       (msv (make-array class-table-size))
171       (class-id->metaclass-id (make-array class-table-size :initial-element nil))
172       (class-foreign-names (make-array class-table-size))
173       (metaclass-foreign-names (make-array class-table-size))
174       (class-id->ordinal (make-array class-table-size :initial-element nil))
175       (metaclass-id->ordinal (make-array class-table-size :initial-element nil))
176       )
177
178  (flet ((grow-vectors ()
179           (let* ((old-size class-table-size)
180                  (new-size (* 2 old-size)))
181             (declare (fixnum old-size new-size))
182             (macrolet ((extend (v)
183                              `(setq ,v (%extend-vector old-size ,v new-size))))
184                   (extend c)
185                   (extend m)
186                   (extend cw)
187                   (extend mw)
188                   (fill cw nil :start old-size :end new-size)
189                   (fill mw nil :start old-size :end new-size)
190                   (extend csv)
191                   (extend msv)
192                   (extend class-id->metaclass-id)
193                   (fill class-id->metaclass-id nil :start old-size :end new-size)
194                   (extend class-foreign-names)
195                   (extend metaclass-foreign-names)
196                   (extend class-id->ordinal)
197                   (extend metaclass-id->ordinal)
198                   (fill class-id->ordinal nil :start old-size :end new-size)
199                   (fill metaclass-id->ordinal nil
200                         :start old-size :end new-size))
201             (setq class-table-size new-size))))
202    (flet ((assign-next-class-id ()
203             (let* ((id next-objc-class-id))
204               (if (= (incf next-objc-class-id) class-table-size)
205                 (grow-vectors))
206               id))
207           (assign-next-metaclass-id ()
208             (let* ((id next-objc-metaclass-id))
209               (if (= (incf next-objc-metaclass-id) class-table-size)
210                 (grow-vectors))
211               id)))
212      (defun id->objc-class (i)
213        (svref c i))
214      (defun (setf id->objc-class) (new i)
215        (setf (svref c i) new))
216      (defun id->objc-metaclass (i)
217        (svref m i))
218      (defun (setf id->objc-metaclass) (new i)
219        (setf (svref m i) new))
220      (defun id->objc-class-wrapper (i)
221        (svref cw i))
222      (defun (setf id->objc-class-wrapper) (new i)
223        (setf (svref cw i) new))
224      (defun id->objc-metaclass-wrapper (i)
225        (svref mw i))
226      (defun (setf id->objc-metaclass-wrapper) (new i)
227        (setf (svref mw i) new))
228      (defun id->objc-class-slots-vector (i)
229        (svref csv i))
230      (defun (setf id->objc-class-slots-vector) (new i)
231        (setf (svref csv i) new))
232      (defun id->objc-metaclass-slots-vector (i)
233        (svref msv i))
234      (defun (setf id->objc-metaclass-slots-vector) (new i)
235        (setf (svref msv i) new))
236      (defun objc-class-id-foreign-name (i)
237        (svref class-foreign-names i))
238      (defun (setf objc-class-id-foreign-name) (new i)
239        (setf (svref class-foreign-names i) new))
240      (defun objc-metaclass-id-foreign-name (i)
241        (svref metaclass-foreign-names i))
242      (defun (setf objc-metaclass-id-foreign-name) (new i)
243        (setf (svref metaclass-foreign-names i) new))
244      (defun %clear-objc-class-maps ()
245        (with-lock-grabbed (objc-class-lock)
246          (clrhash objc-class-map)
247          (clrhash objc-metaclass-map)
248          (clrhash private-objc-classes)))
249      (flet ((install-objc-metaclass (meta)
250               (or (gethash meta objc-metaclass-map)
251                   (let* ((id (assign-next-metaclass-id))
252                          (meta (%inc-ptr meta 0)))
253                     (setf (gethash meta objc-metaclass-map) id)
254                     (setf (svref m id) meta
255                           (svref msv id)
256                           (make-objc-metaclass-slots-vector meta)
257                           (svref metaclass-id->ordinal id)
258                           (%next-class-ordinal))
259                     id))))
260        (defun register-objc-class (class)
261          "ensure that the class is mapped to a small integer and associate a slots-vector with it."
262          (with-lock-grabbed (objc-class-lock)
263            (ensure-objc-classptr-resolved class)
264            (or (gethash class objc-class-map)
265                (let* ((id (assign-next-class-id))
266                       (class (%inc-ptr class 0))
267                       (meta (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer)))
268                  (setf (gethash class objc-class-map) id)
269                  (setf (svref c id) class
270                        (svref csv id)
271                        (make-objc-class-slots-vector class)
272                        (svref class-id->metaclass-id id)
273                        (install-objc-metaclass meta)
274                        (svref class-id->ordinal id) (%next-class-ordinal))
275                  id)))))
276      (defun objc-class-id (class)
277        (gethash class objc-class-map))
278      (defun objc-metaclass-id (meta)
279        (gethash meta objc-metaclass-map))
280      (defun objc-class-id->objc-metaclass-id (class-id)
281        (svref class-id->metaclass-id class-id))
282      (defun objc-class-id->objc-metaclass (class-id)
283        (svref m (svref class-id->metaclass-id class-id)))
284      (defun objc-class-id->ordinal (i)
285        (svref class-id->ordinal i))
286      (defun (setf objc-class-id->ordinal) (new i)
287        (setf (svref class-id->ordinal i) new))
288      (defun objc-metaclass-id->ordinal (m)
289        (svref metaclass-id->ordinal m))
290      (defun (setf objc-metaclass-id->ordinal) (new m)
291        (setf (svref class-id->ordinal m) new))
292      (defun objc-class-map () objc-class-map)
293      (defun %objc-class-count () next-objc-class-id)
294      (defun objc-metaclass-map () objc-metaclass-map)
295      (defun %objc-metaclass-count () next-objc-metaclass-id)
296      (defun %register-private-objc-class (c name)
297        (setf (gethash c private-objc-classes) 
298              (make-private-objc-class-info :name name)))
299      (defun %get-private-objc-class (c)
300        (gethash c private-objc-classes))
301      (defun private-objc-classes ()
302        private-objc-classes))))
303
304(pushnew #'%clear-objc-class-maps *save-exit-functions* :test #'eq
305         :key #'function-name)
306
307(defun do-all-objc-classes (f)
308  (maphash #'(lambda (ptr id) (declare (ignore ptr)) (funcall f (id->objc-class id)))
309           (objc-class-map)))
310
311(defun canonicalize-registered-class (c)
312  (let* ((id (objc-class-id c)))
313    (if id
314      (id->objc-class id)
315      (error "Class ~S isn't recognized." c))))
316
317(defun canonicalize-registered-metaclass (m)
318  (let* ((id (objc-metaclass-id m)))
319    (if id
320      (id->objc-metaclass id)
321      (error "Class ~S isn't recognized." m))))
322
323(defun canonicalize-registered-class-or-metaclass (x)
324  (if (%objc-metaclass-p x)
325    (canonicalize-registered-metaclass x)
326    (canonicalize-registered-class x)))
327
328
329;;; Open shared libs.
330#+darwin-target
331(progn
332(defloadvar *cocoa-event-process* *initial-process*)
333
334
335(defun current-ns-thread ()
336  (with-cstrs ((class-name "NSThread")
337               (message-selector-name "currentThread"))
338    (let* ((nsthread-class (#_objc_lookUpClass class-name))
339           (message-selector (#_sel_getUid message-selector-name)))
340      (#_objc_msgSend nsthread-class message-selector)
341      nil)))
342 
343(defun create-void-nsthread ()
344  ;; Create an NSThread which does nothing but exit.
345  ;; This'll help to convince the AppKit that we're
346  ;; multitheaded.  (A lot of other things, including
347  ;; the ObjC runtime, seem to have already noticed.)
348  (with-cstrs ((thread-class-name "NSThread")
349               (pool-class-name "NSAutoreleasePool")
350               (thread-message-selector-name "detachNewThreadSelector:toTarget:withObject:")
351               (exit-selector-name "exit")
352               (alloc-selector-name "alloc")
353               (init-selector-name "init")
354               (release-selector-name "release"))
355    (let* ((nsthread-class (#_objc_lookUpClass thread-class-name))
356           (pool-class (#_objc_lookUpClass pool-class-name))
357           (thread-message-selector (#_sel_getUid thread-message-selector-name))
358           (exit-selector (#_sel_getUid exit-selector-name))
359           (alloc-selector (#_sel_getUid alloc-selector-name))
360           (init-selector (#_sel_getUid init-selector-name))
361           (release-selector (#_sel_getUid release-selector-name))
362           (pool (#_objc_msgSend
363                  (#_objc_msgSend pool-class
364                                  alloc-selector)
365                  init-selector)))
366      (unwind-protect
367           (#_objc_msgSend nsthread-class thread-message-selector
368                           :address exit-selector
369                           :address nsthread-class
370                           :address (%null-ptr))
371        (#_objc_msgSend pool release-selector))
372      nil)))
373
374(defun run-in-cocoa-process-and-wait  (f)
375  (let* ((process *cocoa-event-process*)
376         (success (cons nil nil))
377         (done (make-semaphore)))
378    (process-interrupt process #'(lambda ()
379                                   (unwind-protect
380                                        (progn
381                                          (setf (car success) (funcall f)))
382                                     (signal-semaphore done))))
383    (wait-on-semaphore done)
384    (car success)))
385
386
387(def-ccl-pointers cocoa-framework ()
388  (run-in-cocoa-process-and-wait
389   #'(lambda ()
390       ;; We need to load and "initialize" the CoreFoundation library
391       ;; in the thread that's going to process events.  Looking up a
392       ;; symbol in the library should cause it to be initialized
393       (open-shared-library "/System/Library/Frameworks/Cocoa.framework/Cocoa")
394       ;(#_GetCurrentEventQueue)
395       (current-ns-thread)
396       (create-void-nsthread))))
397
398
399(defun find-cfstring-sections ()
400  (warn "~s is obsolete" 'find-cfstring-sections))
401
402)
403
404#+gnu-objc
405(progn
406(defparameter *gnustep-system-root* "/usr/GNUstep/" "The root of all evil.")
407(defparameter *gnustep-libraries-pathname*
408  (merge-pathnames "System/Library/Libraries/" *gnustep-system-root*))
409
410(defloadvar *pending-loaded-classes* ())
411
412(defcallback register-class-callback (:address class :address category :void)
413  (let* ((id (map-objc-class class)))
414    (unless (%null-ptr-p category)
415      (let* ((cell (or (assoc id *pending-loaded-classes*)
416                       (let* ((c (list id)))
417                         (push c *pending-loaded-classes*)
418                         c))))
419        (push (%inc-ptr category 0) (cdr cell))))))
420
421;;; Shouldn't really be GNU-objc-specific.
422
423(defun get-c-format-string (c-format-ptr c-arg-ptr)
424  (do* ((n 128))
425       ()
426    (declare (fixnum n))
427    (%stack-block ((buf n))
428      (let* ((m (#_vsnprintf buf n c-format-ptr c-arg-ptr)))
429        (declare (fixnum m))
430        (cond ((< m 0) (return nil))
431              ((< m n) (return (%get-cstring buf)))
432              (t (setq n m)))))))
433
434
435
436(defun init-gnustep-framework ()
437  (or (getenv "GNUSTEP_SYSTEM_ROOT")
438      (setenv "GNUSTEP_SYSTEM_ROOT" *gnustep-system-root*))
439  (open-shared-library "libobjc.so.1")
440  (setf (%get-ptr (foreign-symbol-address "_objc_load_callback"))
441        register-class-callback)
442  (open-shared-library (namestring (merge-pathnames "libgnustep-base.so"
443                                                    *gnustep-libraries-pathname*)))
444  (open-shared-library (namestring (merge-pathnames "libgnustep-gui.so"
445                                                    *gnustep-libraries-pathname*))))
446
447(def-ccl-pointers gnustep-framework ()
448  (init-gnustep-framework))
449)
450
451(defun get-appkit-version ()
452  #+apple-objc
453  #&NSAppKitVersionNumber
454  #+gnu-objc
455  (get-foundation-version))
456
457(defun get-foundation-version ()
458  #&NSFoundationVersionNumber
459  #+gnu-objc (%get-cstring (foreign-symbol-address "gnustep_base_version")))
460
461(defparameter *appkit-library-version-number* (get-appkit-version))
462(defparameter *foundation-library-version-number* (get-foundation-version))
463
464(defparameter *extension-framework-paths* ())
465
466;;; An instance of NSConstantString (which is a subclass of NSString)
467;;; consists of a pointer to the NSConstantString class (which the
468;;; global "_NSConstantStringClassReference" conveniently refers to), a
469;;; pointer to an array of 8-bit characters (doesn't have to be #\Nul
470;;; terminated, but doesn't hurt) and the length of that string (not
471;;; counting any #\Nul.)
472;;; The global reference to the "NSConstantString" class allows us to
473;;; make instances of NSConstantString, ala the @"foo" construct in
474;;; ObjC.  Sure it's ugly, but it seems to be exactly what the ObjC
475;;; compiler does.
476
477
478(defloadvar *NSConstantString-class*
479  (with-cstrs ((name "NSConstantString"))
480    #+apple-objc (#_objc_lookUpClass name)
481    #+gnu-objc (#_objc_lookup_class name)))
482
483
484
485
486#+apple-objc
487(progn
488;;; NSException-handling stuff.
489;;; First, we have to jump through some hoops so that #_longjmp can
490;;; jump through some hoops (a jmp_buf) and wind up throwing to a
491;;; lisp catch tag.
492
493;;; These constants (offsets in the jmp_buf structure) come from
494;;; the _setjmp.h header file in the Darwin LibC source.
495
496#+ppc32-target
497(progn
498(defconstant JMP-lr #x54 "link register (return address) offset in jmp_buf")
499#|(defconstant JMP-ctr #x5c "count register jmp_buf offset")|#
500(defconstant JMP-sp 0 "stack pointer offset in jmp_buf")
501(defconstant JMP-r14 12 "offset of r14 (which we clobber) in jmp_buf")
502(defconstant JMP-r15 16 "offset of r14 (which we also clobber) in jmp_buf"))
503
504#+ppc64-target
505(progn
506(defconstant JMP-lr #xa8 "link register (return address) offset in jmp_buf")
507#|(defconstant JMP-ctr #x5c "count register jmp_buf offset")|#
508(defconstant JMP-sp 0 "stack pointer offset in jmp_buf")
509(defconstant JMP-r13 #x10 "offset of r13 (which we preserve) in jmp_buf")
510(defconstant JMP-r14 #x18 "offset of r14 (which we clobber) in jmp_buf")
511(defconstant JMP-r15 #x20 "offset of r15 (which we also clobber) in jmp_buf"))
512
513;;; These constants also come from Libc sources.  Hey, who needs
514;;; header files ?
515#+x8664-target
516(progn
517(defconstant JB-RBX 0)
518(defconstant JB-RBP 8)
519(defconstant JB-RSP 16)
520(defconstant JB-R12 24)
521(defconstant JB-R13 32)
522(defconstant JB-R14 40)
523(defconstant JB-R15 48)
524(defconstant JB-RIP 56)
525(defconstant JB-RFLAGS 64)
526(defconstant JB-MXCSR 72)
527(defconstant JB-FPCONTROL 76)
528(defconstant JB-MASK 80)
529)
530
531;;; I think that we know where these constants come from.
532#+x8632-target
533(progn
534  (defconstant JB-FPCW 0)
535  (defconstant JB-MASK 4)
536  (defconstant JB-MXCSR 8)
537  (defconstant JB-EBX 12)
538  (defconstant JB-ECX 16)
539  (defconstant JB-EDX 20)
540  (defconstant JB-EDI 24)
541  (defconstant JB-ESI 28)
542  (defconstant JB-EBP 32)
543  (defconstant JB-ESP 36)
544  (defconstant JB-SS 40)
545  (defconstant JB-EFLAGS 44)
546  (defconstant JB-EIP 48)
547  (defconstant JB-CS 52)
548  (defconstant JB-DS 56)
549  (defconstant JB-ES 60)
550  (defconstant JB-FS 64)
551  (defconstant JB-GS 68)
552
553
554  )
555
556 
557
558;;; A malloc'ed pointer to three words of machine code.  The first
559;;; instruction copies the address of the trampoline callback from r14
560;;; to the count register.  The second instruction (rather obviously)
561;;; copies r15 to r4.  A C function passes its second argument in r4,
562;;; but since r4 isn't saved in a jmp_buf, we have to do this copy.
563;;; The second instruction just jumps to the address in the count
564;;; register, which is where we really wanted to go in the first
565;;; place.
566
567#+ppc-target
568(macrolet ((ppc-lap-word (instruction-form)
569             (uvref (uvref (compile nil
570                                    `(lambda (&lap 0)
571                                      (ppc-lap-function () ((?? 0))
572                                       ,instruction-form)))
573                           0) #+ppc64-target 1 #+ppc32-target 0)))
574  (defloadvar *setjmp-catch-lr-code*
575      (let* ((p (malloc 12)))
576        (setf (%get-unsigned-long p 0) (ppc-lap-word (mtctr 14))
577              (%get-unsigned-long p 4) (ppc-lap-word (mr 4 15))
578              (%get-unsigned-long p 8) (ppc-lap-word (bctr)))
579        ;;; Force this code out of the data cache and into memory, so
580        ;;; that it'll get loaded into the icache.
581        (ff-call (%kernel-import #.target::kernel-import-makedataexecutable) 
582                 :address p 
583                 :unsigned-fullword 12
584                 :void)
585        p)))
586
587;;; This isn't used; it isn't right, either.
588#+x8664-target
589(defloadvar *setjmp-catch-rip-code*
590    (let* ((code-bytes '(#x4c #x89 #xe6     ; movq %r12, %rsi
591                         #xff #xd3))        ; call *%rbx
592           (nbytes (length code-bytes))
593           (p (malloc nbytes)))
594      (dotimes (i nbytes p)
595        (setf (%get-unsigned-byte p i) (pop code-bytes)))))
596
597#+x8632-target
598(defloadvar *setjmp-catch-rip-code*
599    (let* ((code-bytes '(#x83 #xec #x10 ; subl $16,%esp
600                         #x89 #x04 #x24 ; movl %eax,(%esp)
601                         #x89 #x7c #x24 #x04   ; movl %edi,4(%esp)
602                         #xff #xd3))    ; call *%ebx
603           (nbytes (length code-bytes))
604           (p (malloc nbytes)))
605      (dotimes (i nbytes p)
606        (setf (%get-unsigned-byte p i) (pop code-bytes)))))
607
608;;; Catch frames are allocated on a stack, so it's OK to pass their
609;;; addresses around to foreign code.
610(defcallback throw-to-catch-frame (:signed-fullword value
611                                   :address frame
612                                   :void)
613  (throw (%get-object frame target::catch-frame.catch-tag) value))
614
615;;; Initialize a jmp_buf so that when it's #_longjmp-ed to, it'll
616;;; wind up calling THROW-TO-CATCH-FRAME with the specified catch
617;;; frame as its second argument.  The C frame used here is just
618;;; an empty C stack frame from which the callback will be called.
619
620#+ppc-target
621(defun %associate-jmp-buf-with-catch-frame (jmp-buf catch-frame c-frame)
622  (%set-object jmp-buf JMP-sp c-frame)
623  (%set-object jmp-buf JMP-r15 catch-frame)
624  #+ppc64-target
625  (%set-object jmp-buf JMP-r13 (%get-os-context))
626  (setf (%get-ptr jmp-buf JMP-lr) *setjmp-catch-lr-code*
627        (%get-ptr jmp-buf JMP-r14) throw-to-catch-frame)
628  t)
629
630#+x8664-target
631(defun %associate-jmp-buf-with-catch-frame (jmp-buf catch-frame c-frame)
632  (setf (%get-ptr jmp-buf JB-rbx) throw-to-catch-frame
633        (%get-ptr jmp-buf JB-rip) *setjmp-catch-rip-code*)
634  (setf (%get-unsigned-long jmp-buf JB-mxcsr) #x1f80
635        (%get-unsigned-long jmp-buf JB-fpcontrol) #x37f)
636  (%set-object jmp-buf JB-RSP c-frame)
637  (%set-object jmp-buf JB-RBP c-frame)
638  (%set-object jmp-buf JB-r12 catch-frame)
639  t)
640
641#+x8632-target
642;;; Ugh.  Apple stores segment register values in jmp_bufs.  You know,
643;;; since they're so volatile and everything.
644(defun %associate-jmp-buf-with-catch-frame (jmp-buf catch-frame c-frame)
645  (setf (%get-unsigned-word jmp-buf JB-FS) (%get-fs-register)
646        (%get-unsigned-word jmp-buf JB-GS) (%get-gs-register)
647        (%get-unsigned-word jmp-buf JB-CS) #x17
648        (%get-unsigned-word jmp-buf JB-DS) #x1f
649        (%get-unsigned-word jmp-buf JB-ES) #x1f
650        (%get-unsigned-word jmp-buf JB-SS) #x1f)
651  (%set-object jmp-buf JB-ESP c-frame)
652  (%set-object jmp-buf JB-EBP c-frame)
653  (setf (%get-unsigned-long jmp-buf JB-MXCSR) #x1f80
654        (%get-unsigned-long jmp-buf JB-FPCW) #x37f
655        (%get-unsigned-long jmp-buf JB-MASK) 0)
656  (setf (%get-ptr jmp-buf JB-EBX) throw-to-catch-frame
657        (%get-ptr jmp-buf JB-EIP) *setjmp-catch-rip-code*)
658  (%set-object jmp-buf JB-EDI catch-frame)
659  t)
660 
661
662       
663
664)
665
666;;; When starting up an image that's had ObjC classes in it, all of
667;;; those canonical classes (and metaclasses) will have had their type
668;;; changed (by SAVE-APPLICATION) to, CCL::DEAD-MACPTR and the addresses
669;;; of those classes may be bogus.  The hash tables (objc-class/metaclass-map)
670;;; should be empty.
671;;; For each class that -had- had an assigned ID, determine its ObjC
672;;; class name, and ask ObjC where (if anywhere) the class is now.
673;;; If we get a non-null answer, revive the class pointer and set its
674;;; address appropriately, then add an entry to the hash-table; this
675;;; means that classes that existed on both sides of SAVE-APPLICATION
676;;; will retain the same ID.
677
678(defun revive-objc-classes ()
679  ;; We need to do some things so that we can use (@class ...)
680  ;; and (@selector ...) early.
681  (invalidate-objc-class-descriptors)
682  (clear-objc-selectors)
683  (clear-objc-protocols)
684  (reset-objc-class-count)
685  ;; Ensure that any addon frameworks are loaded.
686  (dolist (path *extension-framework-paths*)
687    (%reload-objc-framework path))
688  ;; Make a first pass over the class and metaclass tables;
689  ;; resolving those foreign classes that existed in the old
690  ;; image and still exist in the new.
691  (let* ((class-map (objc-class-map))
692         (metaclass-map (objc-metaclass-map))
693         (nclasses (%objc-class-count)))
694    (dotimes (i nclasses)
695      (let* ((c (id->objc-class i))
696             (meta-id (objc-class-id->objc-metaclass-id i))
697             (m (id->objc-metaclass meta-id)))
698        (unless (typep c 'macptr)
699          (%revive-macptr c)
700          (%setf-macptr c (%null-ptr)))
701        (unless (typep m 'macptr)
702          (%revive-macptr m)
703          (%setf-macptr m (%null-ptr)))
704        (unless (gethash c class-map)
705          (%set-pointer-to-objc-class-address (objc-class-id-foreign-name i) c)
706          ;; If the class is valid and the metaclass is still
707          ;; unmapped, set the metaclass pointer's address and map it.
708          (unless (%null-ptr-p c)
709            (setf (gethash c class-map) i)
710            (unless (gethash m metaclass-map)
711              (%setf-macptr m (pref c #+apple-objc :objc_class.isa
712                                      #+gnu-objc :objc_class.class_pointer))
713              (setf (gethash m metaclass-map) meta-id))
714            (note-class-protocols c)))))
715    ;; Second pass: install class objects for user-defined classes,
716    ;; assuming the superclasses are already "revived".  If the
717    ;; superclass is itself user-defined, it'll appear first in the
718    ;; class table; that's an artifact of the current implementation.
719    (dotimes (i nclasses)
720      (let* ((c (id->objc-class i)))
721        (when (and (%null-ptr-p c)
722                   (not (slot-value c 'foreign)))
723          (let* ((super (dolist (s (class-direct-superclasses c)
724                                 (error "No ObjC superclass of ~s" c))
725                          (when (objc-class-p s) (return s))))
726                 (meta-id (objc-class-id->objc-metaclass-id i))
727                 (m (id->objc-metaclass meta-id)))
728            (let* ((class (make-objc-class-pair super (make-cstring (objc-class-id-foreign-name i))))
729                   (meta (pref class #+apple-objc :objc_class.isa
730                               #+gnu-objc :objc-class.class_pointer)))
731            (unless (gethash m metaclass-map)
732              (%revive-macptr m)
733              (%setf-macptr m meta)
734              (setf (gethash m metaclass-map) meta-id))
735            (%setf-macptr c class))
736            #+apple-objc-2.0
737            (%revive-foreign-slots c)
738            #+apple-objc-2.0
739            (%add-objc-class c)
740            #-apple-objc-2.0
741            (multiple-value-bind (ivars instance-size)
742                (%make-objc-ivars c)
743              (%add-objc-class c ivars instance-size))
744            (setf (gethash c class-map) i)))))
745    ;; Finally, iterate over all classes in the runtime world.
746    ;; Register any class that's not found in the class map
747    ;; as a "private" ObjC class.
748    ;; Iterate over all classes in the runtime.  Those that
749    ;; aren't already registered will get identified as
750    ;; "private" (undeclared) ObjC classes.
751    ;; Note that this means that if an application bundle
752    ;; was saved on (for instance) Panther and Tiger interfaces
753    ;; were used, and then the application is run on Tiger, any
754    ;; Tiger-specific classes will not be magically integrated
755    ;; into CLOS in the running application.
756    ;; A development envronment might want to provide such a
757    ;; mechanism; it would need access to Panther class
758    ;; declarations, and - in the general case - a standalone
759    ;; application doesn't necessarily have access to the
760    ;; interface database.
761    (map-objc-classes nil)
762    ))
763
764(pushnew #'revive-objc-classes *lisp-system-pointer-functions*
765         :test #'eq
766         :key #'function-name)
767   
768
769(defun %objc-class-instance-size (c)
770  #+apple-objc-2.0
771  (#_class_getInstanceSize c)
772  #-apple-objc-2.0
773  (pref c :objc_class.instance_size))
774
775(defun find-named-objc-superclass (class string)
776  (unless (or (null string) (%null-ptr-p class))
777    (with-macptrs ((name #+apple-objc-2.0 (#_class_getName class)
778                         #-apple-objc-2.0 (pref class :objc_class.name)))
779      (or
780       (dotimes (i (length string) class)
781         (let* ((b (%get-unsigned-byte name i)))
782           (unless (eq b (char-code (schar string i)))
783             (return))))
784       (find-named-objc-superclass #+apple-objc-2.0 (#_class_getSuperclass class)
785                                   #-apple-objc-2.0 (pref class :objc_class.super_class)
786                                   string)))))
787
788(defun install-foreign-objc-class (class &optional (use-db t))
789  (let* ((id (objc-class-id class)))
790    (unless id
791      (let* ((name (%get-cstring #+apple-objc-2.0 (#_class_getName class)
792                                 #-apple-objc-2.0 (pref class :objc_class.name)))
793             (decl (get-objc-class-decl name use-db)))
794        (if (null decl)
795          (or (%get-private-objc-class class)
796              (%register-private-objc-class class name))
797          (progn
798            (setq id (register-objc-class class)
799                  class (id->objc-class id))
800            ;; If not mapped, map the superclass (if there is one.)
801            (let* ((super (find-named-objc-superclass
802                           #+apple-objc-2.0
803                           (#_class_getSuperclass class)
804                           #-apple-objc-2.0
805                           (pref class :objc_class.super_class)
806                           (db-objc-class-info-superclass-name decl))))
807              (unless (null super)
808                (install-foreign-objc-class super))
809              (let* ((class-name 
810                      (objc-to-lisp-classname
811                       name
812                       "NS"))
813                     (meta-id
814                      (objc-class-id->objc-metaclass-id id)) 
815                     (meta (id->objc-metaclass meta-id)))
816                ;; Metaclass may already be initialized.  It'll have a
817                ;; class wrapper if so.
818                (unless (id->objc-metaclass-wrapper meta-id)
819                  (let* ((meta-foreign-name
820                          (%get-cstring
821                           #+apple-objc-2.0
822                           (#_class_getName meta)
823                           #-apple-objc-2.0
824                           (pref meta :objc_class.name)))
825                         (meta-name
826                          (intern
827                           (concatenate 'string
828                                        "+"
829                                        (string
830                                         (objc-to-lisp-classname
831                                          meta-foreign-name
832                                          "NS")))
833                           "NS"))
834                         (meta-super
835                          (if super (pref super #+apple-objc :objc_class.isa
836                                          #+gnu-objc :objc_class.class_pointer))))
837                    ;; It's important (here and when initializing the
838                    ;; class below) to use the "canonical"
839                    ;; (registered) version of the class, since some
840                    ;; things in CLOS assume EQness.  We probably
841                    ;; don't want to violate that assumption; it'll be
842                    ;; easier to revive a saved image if we don't have
843                    ;; a lot of EQL-but-not-EQ class pointers to deal
844                    ;; with.
845                    (initialize-instance
846                     meta
847                     :name meta-name
848                     :direct-superclasses
849                     (list
850                      (if (or (null meta-super)
851                              (not (%objc-metaclass-p meta-super)))
852                        (find-class 'objc:objc-class)
853                        (canonicalize-registered-metaclass meta-super)))
854                     :peer class
855                     :foreign t)
856                    (setf (objc-metaclass-id-foreign-name meta-id)
857                          meta-foreign-name)
858                    (setf (find-class meta-name) meta)
859                    (%defglobal meta-name meta)))
860                (setf (slot-value class 'direct-slots)
861                      (compute-objc-direct-slots-from-info decl class))
862                (initialize-instance
863                 class
864                 :name class-name
865                 :direct-superclasses
866                 (list
867                  (if (null super)
868                    (find-class 'objc:objc-object)
869                    (canonicalize-registered-class super)))
870                 :peer meta
871                 :foreign t)
872                (setf (objc-class-id-foreign-name id)
873                      name)
874                (setf (find-class class-name) class)
875                (%defglobal class-name class)
876                class))))))))
877                               
878
879
880;;; Execute the body with the variable NSSTR bound to a
881;;; stack-allocated NSConstantString instance (made from
882;;; *NSConstantString-class*, CSTRING and LEN).
883(defmacro with-nsstr ((nsstr cstring len) &body body)
884  #+apple-objc
885  `(rlet ((,nsstr :<NSC>onstant<S>tring
886           :isa *NSConstantString-class*
887           :bytes ,cstring
888           :num<B>ytes ,len))
889      ,@body)
890  #+gnu-objc
891  `(rlet ((,nsstr :<NXC>onstant<S>tring
892           :isa *NSConstantString-class*
893           :c_string ,cstring
894           :len ,len))
895    ,@body))
896
897;;; Make a persistent (heap-allocated) NSConstantString.
898
899(defun %make-constant-nsstring (string)
900  "Make a persistent (heap-allocated) NSConstantString from the
901argument lisp string."
902  #+apple-objc
903  (make-record :<NSC>onstant<S>tring
904               :isa *NSConstantString-Class*
905               :bytes (make-cstring string)
906               :num<B>ytes (length string))
907  #+gnu-objc
908  (make-record :<NXC>onstant<S>tring
909               :isa *NSConstantString-Class*
910               :c_string (make-cstring string)
911               :len (length string))
912  )
913
914;;; Class declarations
915(defparameter *objc-class-declarations* (make-hash-table :test #'equal))
916
917(defun register-objc-class-decls ()
918  (do-interface-dirs (d)
919    (dolist (class-name (cdb-enumerate-keys (db-objc-classes d)))
920      (get-objc-class-decl class-name t))))
921
922
923(defun get-objc-class-decl (class-name &optional (use-db nil))
924  (or (gethash class-name *objc-class-declarations*)
925      (and use-db
926           (let* ((decl (%find-objc-class-info class-name)))
927             (when decl
928               (setf (gethash class-name *objc-class-declarations*) decl))))))
929
930(defun %ensure-class-declaration (name super-name)
931  (unless (get-objc-class-decl name)
932    (setf (gethash name *objc-class-declarations*)
933          (make-db-objc-class-info :class-name (string name)
934                                   :superclass-name (string super-name))))
935  name)
936
937;;; It's hard (and questionable) to allow ivars here.
938(defmacro declare-objc-class (name super-name)
939  `(%ensure-class-declaration ',name ',super-name))
940
941;;; Intern NSConstantString instances.
942(defvar *objc-constant-strings* (make-hash-table :test #'equal))
943
944(defstruct objc-constant-string
945  string
946  nsstringptr)
947
948(defun ns-constant-string (string)
949  (or (gethash string *objc-constant-strings*)
950      (setf (gethash string *objc-constant-strings*)
951            (make-objc-constant-string :string string
952                                       :nsstringptr (%make-constant-nsstring string)))))
953
954(def-ccl-pointers objc-strings ()
955  (maphash #'(lambda (string cached)
956               (setf (objc-constant-string-nsstringptr cached)
957                     (%make-constant-nsstring string)))
958           *objc-constant-strings*))
959
960(defmethod make-load-form ((s objc-constant-string) &optional env)
961  (declare (ignore env))
962  `(ns-constant-string ,(objc-constant-string-string s)))
963
964(defmacro @ (string)
965  `(objc-constant-string-nsstringptr ,(ns-constant-string string)))
966
967#+gnu-objc
968(progn
969  (defcallback lisp-objc-error-handler (:id receiver :int errcode (:* :char) format :address argptr :<BOOL>)
970    (let* ((message (get-c-format-string format argptr)))
971      (error "ObjC runtime error ~d, receiver ~s :~& ~a"
972             errcode receiver message))
973    #$YES)
974
975  (def-ccl-pointers install-lisp-objc-error-handler ()
976    (#_objc_set_error_handler lisp-objc-error-handler)))
977
978
979
980
981
982;;; Registering named objc classes.
983
984
985(defun objc-class-name-string (name)
986  (etypecase name
987    (symbol (lisp-to-objc-classname name))
988    (string name)))
989
990;;; We'd presumably cache this result somewhere, so we'd only do the
991;;; lookup once per session (in general.)
992(defun lookup-objc-class (name &optional error-p)
993  (with-cstrs ((cstr (objc-class-name-string name)))
994    (let* ((p (#+apple-objc #_objc_lookUpClass
995               #+gnu-objc #_objc_lookup_class
996               cstr)))
997      (if (%null-ptr-p p)
998        (if error-p
999          (error "ObjC class ~a not found" name))
1000        p))))
1001
1002(defun %set-pointer-to-objc-class-address (class-name-string ptr)
1003  (with-cstrs ((cstr class-name-string))
1004    (%setf-macptr ptr
1005                  (#+apple-objc #_objc_lookUpClass
1006                   #+gnu-objc #_objc_lookup_class
1007                   cstr)))
1008  nil)
1009   
1010                 
1011
1012(defvar *objc-class-descriptors* (make-hash-table :test #'equal))
1013
1014
1015(defstruct objc-class-descriptor
1016  name
1017  classptr)
1018
1019(defun invalidate-objc-class-descriptors ()
1020  (maphash #'(lambda (name descriptor)
1021               (declare (ignore name))
1022               (setf (objc-class-descriptor-classptr descriptor) nil))
1023           *objc-class-descriptors*))
1024
1025(defun %objc-class-classptr (class-descriptor &optional (error-p t))
1026  (or (objc-class-descriptor-classptr class-descriptor)
1027      (setf (objc-class-descriptor-classptr class-descriptor)
1028            (lookup-objc-class (objc-class-descriptor-name class-descriptor)
1029                               error-p))))
1030
1031(defun load-objc-class-descriptor (name)
1032  (let* ((descriptor (or (gethash name *objc-class-descriptors*)
1033                         (setf (gethash name *objc-class-descriptors*)
1034                               (make-objc-class-descriptor  :name name)))))
1035    (%objc-class-classptr descriptor nil)
1036    descriptor))
1037
1038(defmacro objc-class-descriptor (name)
1039  `(load-objc-class-descriptor ,name))
1040
1041(defmethod make-load-form ((o objc-class-descriptor) &optional env)
1042  (declare (ignore env))
1043  `(load-objc-class-descriptor ,(objc-class-descriptor-name o)))
1044
1045(defmacro @class (name)
1046  (let* ((name (objc-class-name-string name)))
1047    `(the (@metaclass ,name) (%objc-class-classptr ,(objc-class-descriptor name)))))
1048
1049;;; This isn't quite the inverse operation of LOOKUP-OBJC-CLASS: it
1050;;; returns a simple C string.  and can be applied to a class or any
1051;;; instance (returning the class name.)
1052(defun objc-class-name (object)
1053  #+apple-objc
1054  (with-macptrs (p)
1055    (%setf-macptr p (#_object_getClassName object))
1056    (unless (%null-ptr-p p)
1057      (%get-cstring p)))
1058  #+gnu-objc
1059  (unless (%null-ptr-p object)
1060    (with-macptrs ((parent (pref object :objc_object.class_pointer)))
1061      (unless (%null-ptr-p parent)
1062        (if (logtest (pref parent :objc_class.info) #$_CLS_CLASS)
1063          (%get-cstring (pref parent :objc_class.name))
1064          (%get-cstring (pref object :objc_class.name)))))))
1065
1066
1067;;; Likewise, we want to cache the selectors ("SEL"s) which identify
1068;;; method names.  They can vary from session to session, but within
1069;;; a session, all methods with a given name (e.g, "init") will be
1070;;; represented by the same SEL.
1071(defun get-selector-for (method-name &optional error)
1072  (with-cstrs ((cmethod-name method-name))
1073    (let* ((p (#+apple-objc #_sel_getUid
1074               #+gnu-objc #_sel_get_uid
1075               cmethod-name)))
1076      (if (%null-ptr-p p)
1077        (if error
1078          (error "Can't find ObjC selector for ~a" method-name))
1079        p))))
1080
1081(defvar *objc-selectors* (make-hash-table :test #'equal))
1082
1083(defstruct objc-selector
1084  name
1085  %sel)
1086
1087(defun %get-SELECTOR (selector &optional (error-p t))
1088  (or (objc-selector-%sel selector)
1089      (setf (objc-selector-%sel selector)
1090            (get-selector-for (objc-selector-name selector) error-p))))
1091
1092(defun clear-objc-selectors ()
1093  (maphash #'(lambda (name sel)
1094               (declare (ignore name))
1095               (setf (objc-selector-%sel sel) nil))
1096           *objc-selectors*))
1097
1098;;; Find or create a SELECTOR; don't bother resolving it.
1099(defun ensure-objc-selector (name)
1100  (setq name (string name))
1101  (or (gethash name *objc-selectors*)
1102      (setf (gethash name *objc-selectors*)
1103            (make-objc-selector :name name))))
1104
1105(defun load-objc-selector (name)
1106  (let* ((selector (ensure-objc-selector name)))
1107    (%get-SELECTOR selector nil)
1108    selector))
1109
1110(defmacro @SELECTOR (name)
1111  `(%get-selector ,(load-objc-selector name)))
1112
1113(defmethod make-load-form ((s objc-selector) &optional env)
1114  (declare (ignore env))
1115  `(load-objc-selector ,(objc-selector-name s)))
1116
1117
1118;;; Convert a Lisp object X to a desired foreign type FTYPE
1119;;; The following conversions are currently done:
1120;;;   - T/NIL => #$YES/#$NO
1121;;;   - NIL => (%null-ptr)
1122;;;   - Lisp numbers  => SINGLE-FLOAT when possible
1123
1124(defun coerce-to-bool (x)
1125  (let ((x-temp (gensym)))
1126    `(let ((,x-temp ,x))
1127       (if (or (eq ,x-temp 0) (null ,x-temp))
1128         #.#$NO
1129         #.#$YES))))
1130
1131(declaim (inline %coerce-to-bool))
1132(defun %coerce-to-bool (x)
1133  (if (and x (not (eql x 0)))
1134    #$YES
1135    #$NO))
1136
1137(defun coerce-to-address (x)
1138  (let ((x-temp (gensym)))
1139    `(let ((,x-temp ,x))
1140       (cond ((null ,x-temp) +null-ptr+)
1141             (t ,x-temp)))))
1142
1143;;; This is generally a bad idea; it forces us to
1144;;; box intermediate pointer arguments in order
1145;;; to typecase on them, and it's not clear to
1146;;; me that it offers much in the way of additional
1147;;; expressiveness.
1148(declaim (inline %coerce-to-address))
1149(defun %coerce-to-address (x)
1150  (etypecase x
1151    (macptr x)
1152    (null (%null-ptr))))
1153
1154(defun coerce-to-foreign-type (x ftype)
1155   (cond ((and (constantp x) (constantp ftype))
1156          (case ftype
1157            (:id (if (null x) `(%null-ptr) (coerce-to-address x)))
1158            (:<BOOL> (coerce-to-bool (eval x)))
1159            (t x)))
1160         ((constantp ftype)
1161          (case ftype
1162            (:id `(%coerce-to-address ,x))
1163            (:<BOOL> `(%coerce-to-bool ,x))
1164            (t x)))
1165         (t `(case ,(if (atom ftype) ftype)
1166               (:id (%coerce-to-address ,x))
1167               (:<BOOL> (%coerce-to-bool ,x))
1168               (t ,x)))))
1169
1170(defun objc-arg-coerce (typespec arg)
1171  (case typespec
1172    (:<BOOL> `(%coerce-to-bool ,arg))
1173    (:id `(%coerce-to-address ,arg))
1174    (t arg)))
1175
1176
1177;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1178;;;;                       Boolean Return Hackery                           ;;;;
1179;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1180
1181;;; Convert a foreign object X to T or NIL
1182
1183(defun coerce-from-bool (x)
1184  (cond
1185   ((eq x #$NO) nil)
1186   ((eq x #$YES) t)
1187   (t (error "Cannot coerce ~S to T or NIL" x))))
1188
1189(defun objc-result-coerce (type result)
1190  (cond ((eq type :<BOOL>)
1191         `(coerce-from-bool ,result))
1192        (t result)))
1193
1194;;; Add a faster way to get the message from a SEL by taking advantage of the
1195;;; fact that a selector is really just a canonicalized, interned C string
1196;;; containing the message.  (This is an admitted modularity violation;
1197;;; there's a more portable but slower way to do this if we ever need to.)
1198
1199
1200(defun lisp-string-from-sel (sel)
1201  (%get-cstring
1202   #+apple-objc sel
1203   #+gnu-objc (#_sel_get_name sel)))
1204
1205;;; #_objc_msgSend takes two required arguments (the receiving object
1206;;; and the method selector) and 0 or more additional arguments;
1207;;; there'd have to be some macrology to handle common cases, since we
1208;;; want the compiler to see all of the args in a foreign call.
1209
1210;;; I don't remmber what the second half of the above comment might
1211;;; have been talking about.
1212
1213(defmacro objc-message-send (receiver selector-name &rest argspecs)
1214  (when (evenp (length argspecs))
1215    (setq argspecs (append argspecs '(:id))))
1216  #+apple-objc
1217  (funcall (ftd-ff-call-expand-function *target-ftd*)
1218           `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSend"))))
1219           `(:address ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
1220           :arg-coerce 'objc-arg-coerce
1221           :result-coerce 'objc-result-coerce) 
1222  #+gnu-objc
1223    (let* ((r (gensym))
1224         (s (gensym))
1225         (imp (gensym)))
1226    `(with-macptrs ((,r ,receiver)
1227                    (,s (@selector ,selector-name))
1228                    (,imp (external-call "objc_msg_lookup"
1229                                        :id ,r
1230                                        :<SEL> ,s
1231                                        :<IMP>)))
1232      (funcall (ftd-ff-call-expand-function *target-ftd*)
1233       `(%ff-call ,imp)
1234       `(:address ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
1235       :arg-coerce 'objc-arg-coerce
1236       :result-coerce 'objc-result-coerce))))
1237
1238(defmacro objc-message-send-with-selector (receiver selector &rest argspecs)
1239  (when (evenp (length argspecs))
1240    (setq argspecs (append argspecs '(:id))))
1241  #+apple-objc
1242  (funcall (ftd-ff-call-expand-function *target-ftd*)
1243           `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSend"))))
1244           `(:address ,receiver :<SEL> (%get-selector ,selector) ,@argspecs)
1245           :arg-coerce 'objc-arg-coerce
1246           :result-coerce 'objc-result-coerce) 
1247  #+gnu-objc
1248    (let* ((r (gensym))
1249         (s (gensym))
1250         (imp (gensym)))
1251    `(with-macptrs ((,r ,receiver)
1252                    (,s (%get-selector ,selector))
1253                    (,imp (external-call "objc_msg_lookup"
1254                                        :id ,r
1255                                        :<SEL> ,s
1256                                        :<IMP>)))
1257      (funcall (ftd-ff-call-expand-function *target-ftd*)
1258       `(%ff-call ,imp)
1259       `(:address ,receiver :<SEL> ,s ,@argspecs)
1260       :arg-coerce 'objc-arg-coerce
1261       :result-coerce 'objc-result-coerce))))
1262
1263;;; A method that returns a structure does so by platform-dependent
1264;;; means.  One of those means (which is fairly common) is to pass a
1265;;; pointer to an instance of a structure type as a first argument to
1266;;; the method implementation function (thereby making SELF the second
1267;;; argument, etc.), but whether or not it's actually done that way
1268;;; depends on the platform and on the structure type.  The special
1269;;; variable CCL::*TARGET-FTD* holds a structure (of type
1270;;; CCL::FOREIGN-TYPE-DATA) which describes some static attributes of
1271;;; the foreign type system on the target platform and contains some
1272;;; functions which can determine dynamic ABI attributes.  One such
1273;;; function can be used to determine whether or not the "invisible
1274;;; first arg" convention is used to return structures of a given
1275;;; foreign type; another function in *TARGET-FTD* can be used to
1276;;; construct a foreign function call form that handles
1277;;; structure-return and structure-types-as-arguments details.  In the
1278;;; Apple ObjC runtime, #_objc_msgSend_stret must be used if the
1279;;; invisible-first-argument convention is used to return a structure
1280;;; and must NOT be used otherwise. (The Darwin ppc64 and all
1281;;; supported x86-64 ABIs often use more complicated structure return
1282;;; conventions than ppc32 Darwin or ppc Linux.)  We should use
1283;;; OBJC-MESSAGE-SEND-STRET to send any message that returns a
1284;;; structure or union, regardless of how that structure return is
1285;;; actually implemented.
1286
1287(defmacro objc-message-send-stret (structptr receiver selector-name &rest argspecs)
1288    #+apple-objc
1289    (let* ((return-typespec (car (last argspecs)))
1290           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
1291                         "_objc_msgSend_stret"
1292                         "_objc_msgSend")))
1293      (funcall (ftd-ff-call-expand-function *target-ftd*)
1294               `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name))))
1295        `(,structptr :address ,receiver :<SEL> (@selector ,selector-name) ,@argspecs)
1296               :arg-coerce 'objc-arg-coerce
1297               :result-coerce 'objc-result-coerce))
1298    #+gnu-objc
1299    (let* ((r (gensym))
1300         (s (gensym))
1301         (imp (gensym)))
1302    `(with-macptrs ((,r ,receiver)
1303                    (,s (@selector ,selector-name))
1304                    (,imp (external-call "objc_msg_lookup"
1305                                         :id ,r
1306                                         :<SEL> ,s
1307                                         :<IMP>)))
1308      ,      (funcall (ftd-ff-call-expand-function *target-ftd*)
1309               `(%ff-call ,imp)
1310              `(,structptr :address ,receiver :<SEL> ,s ,@argspecs)
1311               :arg-coerce 'objc-arg-coerce
1312               :result-coerce 'objc-result-coerce))))
1313
1314(defmacro objc-message-send-stret-with-selector (structptr receiver selector &rest argspecs)
1315    #+apple-objc
1316    (let* ((return-typespec (car (last argspecs)))
1317           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
1318                         "_objc_msgSend_stret"
1319                         "_objc_msgSend")))
1320      (funcall (ftd-ff-call-expand-function *target-ftd*)
1321               `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name))))
1322        `(,structptr :address ,receiver :<SEL> (%get-selector ,selector) ,@argspecs)
1323               :arg-coerce 'objc-arg-coerce
1324               :result-coerce 'objc-result-coerce))
1325    #+gnu-objc
1326    (let* ((r (gensym))
1327         (s (gensym))
1328         (imp (gensym)))
1329    `(with-macptrs ((,r ,receiver)
1330                    (,s (%get-selector ,selector))
1331                    (,imp (external-call "objc_msg_lookup"
1332                                         :id ,r
1333                                         :<SEL> ,s
1334                                         :<IMP>)))
1335      ,      (funcall (ftd-ff-call-expand-function *target-ftd*)
1336               `(%ff-call ,imp)
1337              `(,structptr :address ,receiver :<SEL> ,s ,@argspecs)
1338               :arg-coerce 'objc-arg-coerce
1339               :result-coerce 'objc-result-coerce))))
1340
1341;;; #_objc_msgSendSuper is similar to #_objc_msgSend; its first argument
1342;;; is a pointer to a structure of type objc_super {self,  the defining
1343;;; class's superclass}.  It only makes sense to use this inside an
1344;;; objc method.
1345(defmacro objc-message-send-super (super selector-name &rest argspecs)
1346  (when (evenp (length argspecs))
1347    (setq argspecs (append argspecs '(:id))))
1348  #+apple-objc
1349  (funcall (ftd-ff-call-expand-function *target-ftd*)
1350           `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSendSuper"))))
1351           `(:address ,super :<SEL> (@selector ,selector-name) ,@argspecs)
1352           :arg-coerce 'objc-arg-coerce
1353           :result-coerce 'objc-result-coerce)
1354  #+gnu-objc
1355  (let* ((sup (gensym))
1356         (sel (gensym))
1357         (imp (gensym)))
1358    `(with-macptrs ((,sup ,super)
1359                    (,sel (@selector ,selector-name))
1360                    (,imp (external-call "objc_msg_lookup_super"
1361                                         :<S>uper_t ,sup
1362                                         :<SEL> ,sel
1363                                         :<IMP>)))
1364  (funcall (ftd-ff-call-expand-function *target-ftd*)
1365   `(%ff-call ,imp)
1366   `(:id (pref ,sup :<S>uper.self)
1367     :<SEL> ,sel
1368     ,@argspecs)))))
1369
1370(defmacro objc-message-send-super-with-selector (super selector &rest argspecs)
1371  (when (evenp (length argspecs))
1372    (setq argspecs (append argspecs '(:id))))
1373  #+apple-objc
1374  (funcall (ftd-ff-call-expand-function *target-ftd*)
1375           `(%ff-call (%reference-external-entry-point (load-time-value (external "_objc_msgSendSuper"))))
1376           `(:address ,super :<SEL> ,selector ,@argspecs)
1377           :arg-coerce 'objc-arg-coerce
1378           :result-coerce 'objc-result-coerce)
1379  #+gnu-objc
1380  (let* ((sup (gensym))
1381         (sel (gensym))
1382         (imp (gensym)))
1383    `(with-macptrs ((,sup ,super)
1384                    (,sel ,selector)
1385                    (,imp (external-call "objc_msg_lookup_super"
1386                                         :<S>uper_t ,sup
1387                                         :<SEL> ,sel
1388                                         :<IMP>)))
1389  (funcall (ftd-ff-call-expand-function *target-ftd*)
1390   `(%ff-call ,imp)
1391   `(:id (pref ,sup :<S>uper.self)
1392     :<SEL> ,sel
1393     ,@argspecs)))))
1394
1395;;; Send to superclass method, returning a structure. See above.
1396(defmacro objc-message-send-super-stret
1397    (structptr super selector-name &rest argspecs)
1398  #+apple-objc
1399    (let* ((return-typespec (car (last argspecs)))
1400           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
1401                         "_objc_msgSendSuper_stret"
1402                         "_objc_msgSendSuper")))
1403      (funcall (ftd-ff-call-expand-function *target-ftd*)
1404               `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name))))
1405               `(,structptr :address ,super :<SEL> (@selector ,selector-name) ,@argspecs)
1406               :arg-coerce 'objc-arg-coerce
1407               :result-coerce 'objc-result-coerce))
1408  #+gnu-objc
1409  (let* ((sup (gensym))
1410         (sel (gensym))
1411         (imp (gensym)))
1412    `(with-macptrs ((,sup ,super)
1413                    (,sel (@selector ,selector-name))
1414                    (,imp (external-call "objc_msg_lookup_super"
1415                                         :<S>uper_t ,sup
1416                                         :<SEL> ,sel
1417                                         :<IMP>)))
1418      (funcall (ftd-ff-call-expand-function *target-ftd*)
1419       `(%ff-call ,imp)
1420       ,structptr
1421       :id (pref ,sup :<S>uper.self)
1422       :<SEL> ,sel
1423       ,@argspecs))))
1424
1425(defmacro objc-message-send-super-stret-with-selector
1426    (structptr super selector &rest argspecs)
1427  #+apple-objc
1428    (let* ((return-typespec (car (last argspecs)))
1429           (entry-name (if (funcall (ftd-ff-call-struct-return-by-implicit-arg-function *target-ftd*) return-typespec)
1430                         "_objc_msgSendSuper_stret"
1431                         "_objc_msgSendSuper")))
1432      (funcall (ftd-ff-call-expand-function *target-ftd*)
1433               `(%ff-call (%reference-external-entry-point (load-time-value (external ,entry-name))))
1434               `(,structptr :address ,super :<SEL> ,selector ,@argspecs)
1435               :arg-coerce 'objc-arg-coerce
1436               :result-coerce 'objc-result-coerce))
1437  #+gnu-objc
1438  (let* ((sup (gensym))
1439         (sel (gensym))
1440         (imp (gensym)))
1441    `(with-macptrs ((,sup ,super)
1442                    (,sel ,selector)
1443                    (,imp (external-call "objc_msg_lookup_super"
1444                                         :<S>uper_t ,sup
1445                                         :<SEL> ,sel
1446                                         :<IMP>)))
1447      (funcall (ftd-ff-call-expand-function *target-ftd*)
1448       `(%ff-call ,imp)
1449       ,structptr
1450       :id (pref ,sup :<S>uper.self)
1451       :<SEL> ,sel
1452       ,@argspecs))))
1453
1454(defun message-send-form-for-call (receiver selector args super-p struct-return-var)
1455  (if struct-return-var
1456    (if super-p
1457      `(objc-message-send-super-stret-with-selector ,struct-return-var ,receiver ,selector ,@args)
1458      `(objc-message-send-stret-with-selector ,struct-return-var ,receiver ,selector ,@args))
1459    (if super-p
1460      `(objc-message-send-super-with-selector ,receiver ,selector ,@args)
1461      `(objc-message-send-with-selector ,receiver ,selector ,@args))))
1462
1463
1464#+(and apple-objc x8664-target)
1465(defun %process-varargs-list (gpr-pointer fpr-pointer stack-pointer ngprs nfprs nstackargs arglist)
1466  (dolist (arg-temp arglist)
1467    (typecase arg-temp
1468      ((signed-byte 64)
1469       (if (< ngprs 6)
1470         (progn
1471           (setf (paref gpr-pointer (:* (:signed 64)) ngprs) arg-temp)
1472           (incf ngprs))
1473         (progn
1474           (setf (paref stack-pointer (:* (:signed 64)) nstackargs) arg-temp)
1475           (incf nstackargs))))
1476      ((unsigned-byte 64)
1477       (if (< ngprs 6)
1478         (progn
1479           (setf (paref gpr-pointer (:* (:unsigned 64)) ngprs) arg-temp)
1480           (incf ngprs))
1481         (progn
1482           (setf (paref stack-pointer (:* (:unsigned 64)) nstackargs) arg-temp)
1483           (incf nstackargs))))
1484      (macptr
1485       (if (< ngprs 6)
1486         (progn
1487           (setf (paref gpr-pointer (:* :address) ngprs) arg-temp)
1488           (incf ngprs))
1489         (progn
1490           (setf (paref stack-pointer (:* :address) nstackargs) arg-temp)
1491           (incf nstackargs))))
1492      (single-float
1493       (if (< nfprs 8)
1494         (progn
1495           (setf (%get-single-float fpr-pointer (* nfprs 16))
1496                 arg-temp)
1497           (incf nfprs))
1498         (progn
1499           (setf (paref stack-pointer (:* :float) (* 2 nstackargs)) arg-temp)
1500           (incf nstackargs))))
1501      (double-float
1502       (if (< nfprs 8)
1503         (progn
1504           (setf (%get-double-float fpr-pointer (* nfprs 16))
1505                 arg-temp)
1506           (incf nfprs))
1507         (progn
1508           (setf (paref stack-pointer (:* :double) nstackargs)
1509                 arg-temp)
1510           (incf nstackargs)))))))
1511
1512#+(and apple-objc x8632-target)
1513(defun %process-varargs-list (ptr index arglist)
1514  (dolist (arg-temp arglist)
1515    (typecase arg-temp
1516      ((signed-byte 32)
1517       (setf (paref ptr (:* (:signed 32)) index) arg-temp)
1518       (incf index))
1519      ((unsigned-byte 32)
1520       (setf (paref ptr (:* (:unsigned 32)) index) arg-temp)
1521       (incf index))
1522      (macptr
1523       (setf (paref ptr (:* :address) index) arg-temp)
1524       (incf index))
1525      (single-float
1526       (setf (%get-single-float ptr (* 4 index)) arg-temp)
1527       (incf index))
1528      (double-float
1529       (setf (%get-double-float ptr (* 4 index)) arg-temp)
1530       (incf index 2))
1531      ((or (signed-byte 64)
1532           (unsigned-byte 64))
1533       (setf (paref ptr (:* :unsigned) index) (ldb (byte 32 0) arg-temp))
1534       (incf index)
1535       (setf (paref ptr (:* :unsigned) index) (ldb (byte 32 32) arg-temp))
1536       (incf index)))))
1537
1538#+(and apple-objc ppc32-target)
1539(defun %process-varargs-list (gpr-pointer fpr-pointer ngprs nfprs arglist)
1540  (dolist (arg-temp arglist)
1541    (typecase arg-temp
1542      ((signed-byte 32)
1543       (setf (paref gpr-pointer (:* (:signed 32)) ngprs) arg-temp)
1544       (incf ngprs))
1545      ((unsigned-byte 32)
1546       (setf (paref gpr-pointer (:* (:unsigned 32)) ngprs) arg-temp)
1547       (incf ngprs))
1548      (macptr
1549       (setf (paref gpr-pointer (:* :address) ngprs) arg-temp)
1550       (incf ngprs))
1551      (single-float
1552       (when (< nfprs 13)
1553         (setf (paref fpr-pointer (:* :double-float) nfprs) (float arg-temp 0.0d0))
1554         (incf nfprs))
1555       (setf (paref gpr-pointer (:* :single-float) ngprs) arg-temp)
1556       (incf ngprs))
1557      (double-float
1558       (when (< nfprs 13)
1559         (setf (paref fpr-pointer (:* :double-float) nfprs) arg-temp)
1560         (incf nfprs))
1561       (multiple-value-bind (high low) (double-float-bits arg-temp)
1562         (setf (paref gpr-pointer (:* :unsigned) ngprs) high)
1563         (incf ngprs)
1564         (setf (paref gpr-pointer (:* :unsigned) ngprs) low)
1565         (incf nfprs)))
1566      ((or (signed-byte 64)
1567           (unsigned-byte 64))
1568       (setf (paref gpr-pointer (:* :unsigned) ngprs) (ldb (byte 32 32) arg-temp))
1569       (incf ngprs)
1570       (setf (paref gpr-pointer (:* :unsigned) ngprs) (ldb (byte 32 0) arg-temp))
1571       (incf ngprs)))))
1572
1573#+(and apple-objc ppc64-target)
1574(defun %process-varargs-list (gpr-pointer fpr-pointer ngprs nfprs arglist)
1575  (dolist (arg-temp arglist (min nfprs 13))
1576    (typecase arg-temp
1577      ((signed-byte 64)
1578       (setf (paref gpr-pointer (:* (:signed 64)) ngprs) arg-temp)
1579       (incf ngprs))
1580      ((unsigned-byte 64)
1581       (setf (paref gpr-pointer (:* (:unsigned 64)) ngprs) arg-temp)
1582       (incf ngprs))
1583      (macptr
1584       (setf (paref gpr-pointer (:* :address) ngprs) arg-temp)
1585       (incf ngprs))
1586      (single-float
1587       (when (< nfprs 13)
1588         (setf (paref fpr-pointer (:* :double-float) nfprs) (float arg-temp 0.0d0))
1589         (incf nfprs))
1590       (setf (paref gpr-pointer (:* (:unsigned 64)) ngprs) (single-float-bits arg-temp))
1591       (incf ngprs))
1592      (double-float
1593       (when (< nfprs 13)
1594         (setf (paref fpr-pointer (:* :double-float) nfprs) arg-temp)
1595         (incf nfprs))
1596       (setf (paref gpr-pointer (:* :double-float) ngprs) arg-temp)
1597       (incf ngprs)))))
1598
1599                         
1600#+apple-objc
1601(eval-when (:compile-toplevel :execute)
1602  #+(and ppc-target (not apple-objc-2.0))
1603  (def-foreign-type :<MARG>
1604      (:struct nil
1605               (:fp<P>arams (:array :double 13))
1606               (:linkage (:array :uintptr_t 6))
1607               (:reg<P>arams (:array :uintptr_t 8))
1608               (:stack<P>arams (:array :uintptr_t) 0)))
1609  )
1610
1611 
1612#+(and apple-objc-2.0 x8664-target)
1613(defun %compile-varargs-send-function-for-signature (sig)
1614  (let* ((return-type-spec (foreign-type-to-representation-type (car sig)))
1615         (op (case return-type-spec
1616               (:address '%get-ptr)
1617               (:unsigned-byte '%get-unsigned-byte)
1618               (:signed-byte '%get-signed-byte)
1619               (:unsigned-halfword '%get-unsigned-word)
1620               (:signed-halfword '%get-signed-word)
1621               (:unsigned-fullword '%get-unsigned-long)
1622               (:signed-fullword '%get-signed-long)
1623               (:unsigned-doubleword '%get-natural)
1624               (:signed-doubleword '%get-signed-natural)
1625               (:single-float '%get-single-float)
1626               (:double-float '%get-double-float)))
1627         (result-offset
1628          (case op
1629            ((:single-float :double-float) 0)
1630            (t -8)))
1631         (arg-type-specs (butlast (cdr sig)))
1632         (args (objc-gen-message-arglist (length arg-type-specs)))
1633         (receiver (gensym))
1634         (selector (gensym))
1635         (rest-arg (gensym))
1636         (arg-temp (gensym))
1637         (regparams (gensym))
1638         (stackparams (gensym))
1639         (fpparams (gensym))
1640         (cframe (gensym))
1641         (selptr (gensym))
1642         (gpr-total (gensym))
1643         (fpr-total (gensym))
1644         (stack-total (gensym))
1645         (n-static-gprs 2)              ;receiver, selptr
1646         (n-static-fprs 0)
1647         (n-static-stack-args 0))
1648    (collect ((static-arg-forms))
1649      (static-arg-forms `(setf (paref ,regparams (:* address) 0) ,receiver))
1650      (static-arg-forms `(setf (paref ,regparams (:* address) 1) ,selptr))
1651      (do* ((args args (cdr args))
1652            (arg-type-specs arg-type-specs (cdr arg-type-specs)))
1653           ((null args))
1654        (let* ((arg (car args))
1655               (spec (car arg-type-specs))
1656               (static-arg-type (parse-foreign-type spec))
1657               (gpr-base (if (< n-static-gprs 6) regparams stackparams))
1658               (fpr-base (if (< n-static-fprs 8) fpparams stackparams))
1659               (gpr-offset (if (< n-static-gprs 6) n-static-gprs n-static-stack-args))
1660               (fpr-offset (if (< n-static-fprs 8)
1661                             (* 8 n-static-fprs)
1662                             (* 8 n-static-stack-args))))
1663          (etypecase static-arg-type
1664            (foreign-integer-type
1665             (if (eq spec :<BOOL>)
1666               (setq arg `(%coerce-to-bool ,arg)))
1667             (static-arg-forms
1668              `(setf (paref ,gpr-base (:* (
1669                                           ,(if (foreign-integer-type-signed static-arg-type)
1670                                                :signed
1671                                                :unsigned)
1672                                           ,(foreign-integer-type-bits static-arg-type))) ,gpr-offset)
1673                ,arg))
1674             (if (< n-static-gprs 6)
1675               (incf n-static-gprs)
1676               (incf n-static-stack-args)))
1677            (foreign-single-float-type
1678             (static-arg-forms
1679              `(setf (%get-single-float ,fpr-base ,fpr-offset) ,arg))
1680             (if (< n-static-fprs 8)
1681               (incf n-static-fprs)
1682               (incf n-static-stack-args)))
1683            (foreign-double-float-type
1684             (static-arg-forms
1685              `(setf (%get-double-float ,fpr-base ,fpr-offset) ,arg))
1686             (if (< n-static-fprs 8)
1687               (incf n-static-fprs)
1688               (incf n-static-stack-args)))
1689            (foreign-pointer-type
1690             (static-arg-forms
1691              `(setf (paref ,gpr-base (:* address) ,gpr-offset) ,arg))
1692             (if (< n-static-gprs 6)
1693               (incf n-static-gprs)
1694               (incf n-static-stack-args))))))
1695      (compile
1696       nil
1697       `(lambda (,receiver ,selector ,@args &rest ,rest-arg)
1698         (declare (dynamic-extent ,rest-arg))
1699         (let* ((,selptr (%get-selector ,selector))
1700                (,gpr-total ,n-static-gprs)
1701                (,fpr-total ,n-static-fprs)
1702                (,stack-total ,n-static-stack-args))
1703           (dolist (,arg-temp ,rest-arg)
1704             (if (or (typep ,arg-temp 'double-float)
1705                     (typep ,arg-temp 'single-float))
1706               (if (< ,fpr-total 8)
1707                 (incf ,fpr-total)
1708                 (incf ,stack-total))
1709               (if (< ,gpr-total 6)
1710                 (incf ,gpr-total)
1711                 (incf ,stack-total))))
1712           (%stack-block ((,fpparams (* 8 8)))
1713             (with-macptrs (,regparams ,stackparams)
1714               (with-variable-c-frame
1715                   (+ 8 ,stack-total) ,cframe
1716                   (%setf-macptr-to-object ,regparams (+ ,cframe 2))
1717                   (%setf-macptr-to-object ,stackparams (+ ,cframe 8))
1718                   (progn ,@(static-arg-forms))
1719                   (%process-varargs-list ,regparams ,fpparams ,stackparams ,n-static-gprs ,n-static-fprs ,n-static-stack-args ,rest-arg)
1720                   (%do-ff-call ,fpr-total ,cframe ,fpparams (%reference-external-entry-point (load-time-value (external "_objc_msgSend"))))
1721                   ,@(if op
1722                         `((,op ,regparams ,result-offset))
1723                         `(())))))))))))
1724
1725
1726#+(and apple-objc ppc32-target)
1727(defun %compile-varargs-send-function-for-signature (sig)
1728  (let* ((return-type-spec (car sig))
1729         (arg-type-specs (butlast (cdr sig)))
1730         (args (objc-gen-message-arglist (length arg-type-specs)))
1731         (receiver (gensym))
1732         (selector (gensym))
1733         (rest-arg (gensym))
1734         (arg-temp (gensym))
1735         (marg-ptr (gensym))
1736         (regparams (gensym))
1737         (selptr (gensym))
1738         (gpr-total (gensym))
1739         (n-static-gprs 2)              ;receiver, selptr
1740         (n-static-fprs 0))
1741    (collect ((static-arg-forms))
1742      (static-arg-forms `(setf (paref ,regparams (:* address) 0) ,receiver))
1743      (static-arg-forms `(setf (paref ,regparams (:* address) 1) ,selptr))
1744      (do* ((args args (cdr args))
1745            (arg-type-specs arg-type-specs (cdr arg-type-specs)))
1746           ((null args))
1747        (let* ((arg (car args))
1748               (spec (car arg-type-specs))
1749               (static-arg-type (parse-foreign-type spec))
1750               (gpr-base regparams)
1751               (fpr-base marg-ptr)
1752               (gpr-offset (* n-static-gprs 4)))
1753          (etypecase static-arg-type
1754            (foreign-integer-type
1755             (let* ((bits (foreign-type-bits static-arg-type))
1756                    (signed (foreign-integer-type-signed static-arg-type)))
1757               (if (> bits 32)
1758                 (progn
1759                   (static-arg-forms
1760                    `(setf (,(if signed '%%get-signed-longlong '%%get-unsigned-long-long)
1761                            ,gpr-base ,gpr-offset)
1762                      ,arg))
1763                   (incf n-static-gprs 2))
1764                 (progn
1765                   (if (eq spec :<BOOL>)
1766                     (setq arg `(%coerce-to-bool ,arg)))
1767                   (static-arg-forms
1768                    `(setf (paref ,gpr-base (:* (
1769                                                 ,(if (foreign-integer-type-signed static-arg-type)
1770                                                      :signed
1771                                                      :unsigned)
1772                                           32)) ,gpr-offset)
1773                ,arg))
1774                   (incf n-static-gprs)))))
1775            (foreign-single-float-type
1776             (static-arg-forms
1777              `(setf (paref ,gpr-base (:* :single-float) ,n-static-gprs) ,arg))
1778             (when (< n-static-fprs 13)
1779               (static-arg-forms
1780                `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs)
1781                  (float (paref ,gpr-base (:* :single-float) ,n-static-gprs) 0.0d0)))
1782               (incf n-static-fprs))
1783             (incf n-static-gprs))
1784            (foreign-double-float-type
1785             (static-arg-forms
1786              `(setf (%get-double-float ,gpr-base ,gpr-offset) ,arg))
1787             (when (< n-static-fprs 13)
1788               (static-arg-forms
1789                `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs)
1790                  (%get-double-float ,gpr-base ,gpr-offset)))
1791               (incf n-static-fprs))
1792             (incf n-static-gprs 2))
1793            (foreign-pointer-type
1794             (static-arg-forms
1795              `(setf (paref ,gpr-base (:* address) ,n-static-gprs) ,arg))
1796               (incf n-static-gprs)))))
1797      (compile
1798       nil
1799       `(lambda (,receiver ,selector ,@args &rest ,rest-arg)
1800         (declare (dynamic-extent ,rest-arg))
1801         (let* ((,selptr (%get-selector ,selector))
1802                (,gpr-total ,n-static-gprs))
1803           (dolist (,arg-temp ,rest-arg)
1804             (if (or (typep ,arg-temp 'double-float)
1805                     (and (typep ,arg-temp 'integer)
1806                          (if (< ,arg-temp 0)
1807                            (>= (integer-length ,arg-temp) 32)
1808                            (> (integer-length ,arg-temp) 32))))
1809               (incf ,gpr-total 2)
1810               (incf ,gpr-total 1)))
1811           (if (> ,gpr-total 8)
1812             (setq ,gpr-total (- ,gpr-total 8))
1813             (setq ,gpr-total 0))           
1814           (%stack-block ((,marg-ptr (+ ,(%foreign-type-or-record-size
1815                                          :<MARG> :bytes)
1816                                        (* 4 ,gpr-total))))
1817             
1818             (with-macptrs ((,regparams (pref ,marg-ptr :<MARG>.reg<P>arams)))
1819               (progn ,@(static-arg-forms))
1820               (%process-varargs-list ,regparams ,marg-ptr ,n-static-gprs ,n-static-fprs  ,rest-arg)
1821               (external-call "_objc_msgSendv"
1822                              :address ,receiver
1823                              :address ,selptr
1824                              :size_t (+ 32 (* 4 ,gpr-total))
1825                              :address ,marg-ptr
1826                              ,return-type-spec)))))))))
1827
1828#+(and apple-objc x8632-target)
1829(defun %compile-varargs-send-function-for-signature (sig)
1830  (let* ((return-type-spec (car sig))
1831         (arg-type-specs (butlast (cdr sig)))
1832         (args (objc-gen-message-arglist (length arg-type-specs)))
1833         (receiver (gensym))
1834         (selector (gensym))
1835         (rest-arg (gensym))
1836         (arg-temp (gensym))
1837         (marg-ptr (gensym))
1838         (static-arg-words 2)           ;receiver, selptr
1839         (marg-words (gensym))
1840         (marg-size (gensym))
1841         (selptr (gensym)))
1842    (collect ((static-arg-forms))
1843      (static-arg-forms `(setf (paref ,marg-ptr (:* address) 0) ,receiver))
1844      (static-arg-forms `(setf (paref ,marg-ptr (:* address) 1) ,selptr))
1845      (do* ((args args (cdr args))
1846            (arg-type-specs arg-type-specs (cdr arg-type-specs)))
1847           ((null args))
1848        (let* ((arg (car args))
1849               (spec (car arg-type-specs))
1850               (static-arg-type (parse-foreign-type spec)))
1851          (etypecase static-arg-type
1852            (foreign-integer-type
1853             (let* ((bits (foreign-type-bits static-arg-type))
1854                    (signed (foreign-integer-type-signed static-arg-type)))
1855               (if (> bits 32)
1856                 (progn
1857                   (static-arg-forms
1858                    `(setf (,(if signed '%%get-signed-longlong '%%get-unsigned-long-long)
1859                             ,marg-ptr (* 4 ,static-arg-words))
1860                           ,arg))
1861                   (incf static-arg-words 2))
1862                 (progn
1863                   (if (eq spec :<BOOL>)
1864                     (setq arg `(%coerce-to-bool ,arg)))
1865                   (static-arg-forms
1866                    `(setf (paref ,marg-ptr (:* 
1867                                             (,(if (foreign-integer-type-signed 
1868                                                    static-arg-type)
1869                                                   :signed
1870                                                   :unsigned)
1871                                               32)) ,static-arg-words)
1872                           ,arg))
1873                   (incf static-arg-words)))))
1874            (foreign-single-float-type
1875             (static-arg-forms
1876              `(setf (paref ,marg-ptr (:* :single-float) ,static-arg-words) ,arg))
1877             (incf static-arg-words))
1878            (foreign-double-float-type
1879             (static-arg-forms
1880              `(setf (%get-double-float ,marg-ptr (* 4 ,static-arg-words)) ,arg))
1881             (incf static-arg-words 2))
1882            (foreign-pointer-type
1883             (static-arg-forms
1884              `(setf (paref ,marg-ptr (:* address) ,static-arg-words) ,arg))
1885             (incf static-arg-words)))))
1886      (compile
1887       nil
1888       `(lambda (,receiver ,selector ,@args &rest ,rest-arg)
1889          (declare (dynamic-extent ,rest-arg))
1890          (let* ((,selptr (%get-selector ,selector))
1891                 (,marg-words ,static-arg-words)
1892                 (,marg-size nil))
1893            (dolist (,arg-temp ,rest-arg)
1894              (if (or (typep ,arg-temp 'double-float)
1895                      (and (typep ,arg-temp 'integer)
1896                           (if (< ,arg-temp 0)
1897                             (>= (integer-length ,arg-temp) 32)
1898                             (> (integer-length ,arg-temp) 32))))
1899                (incf ,marg-words 2)
1900                (incf ,marg-words 1)))
1901            (setq ,marg-size (ash ,marg-words 2))
1902            (%stack-block ((,marg-ptr ,marg-size))
1903              (progn ,@(static-arg-forms))
1904              (%process-varargs-list ,marg-ptr ,static-arg-words ,rest-arg)
1905              (external-call "_objc_msgSendv"
1906                             :id ,receiver
1907                             :<SEL> ,selptr
1908                             :size_t ,marg-size
1909                             :address ,marg-ptr
1910                             ,return-type-spec))))))))
1911
1912#+(and apple-objc-2.0 ppc64-target)
1913(defun %compile-varargs-send-function-for-signature (sig)
1914  (let* ((return-type-spec (car sig))
1915         (arg-type-specs (butlast (cdr sig)))
1916         (args (objc-gen-message-arglist (length arg-type-specs)))
1917         (receiver (gensym))
1918         (selector (gensym))
1919         (rest-arg (gensym))
1920         (fp-arg-ptr (gensym))
1921         (c-frame (gensym))
1922         (gen-arg-ptr (gensym))
1923         (selptr (gensym))
1924         (gpr-total (gensym))
1925         (n-static-gprs 2)              ;receiver, selptr
1926         (n-static-fprs 0))
1927    (collect ((static-arg-forms))
1928      (static-arg-forms `(setf (paref ,gen-arg-ptr (:* address) 0) ,receiver))
1929      (static-arg-forms `(setf (paref ,gen-arg-ptr (:* address) 1) ,selptr))
1930      (do* ((args args (cdr args))
1931            (arg-type-specs arg-type-specs (cdr arg-type-specs)))
1932           ((null args))
1933        (let* ((arg (car args))
1934               (spec (car arg-type-specs))
1935               (static-arg-type (parse-foreign-type spec))
1936               (gpr-base gen-arg-ptr)
1937               (fpr-base fp-arg-ptr)
1938               (gpr-offset (* n-static-gprs 8)))
1939          (etypecase static-arg-type
1940            (foreign-integer-type
1941             (if (eq spec :<BOOL>)
1942               (setq arg `(%coerce-to-bool ,arg)))
1943             (static-arg-forms
1944              `(setf (paref ,gpr-base (:* (
1945                                           ,(if (foreign-integer-type-signed static-arg-type)
1946                                                :signed
1947                                                :unsigned)
1948                                           64)) ,gpr-offset)
1949                ,arg))
1950             (incf n-static-gprs))
1951            (foreign-single-float-type
1952             (static-arg-forms
1953              `(setf (%get-single-float ,gpr-base ,(+ 4 gpr-offset)) ,arg))
1954             (when (< n-static-fprs 13)
1955               (static-arg-forms
1956                `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs)
1957                  (float (%get-single-float ,gpr-base ,(+ 4 (* 8 n-static-gprs))) 0.0d0)))
1958               (incf n-static-fprs))
1959             (incf n-static-gprs))
1960            (foreign-double-float-type
1961             (static-arg-forms
1962              `(setf (%get-double-float ,gpr-base ,gpr-offset) ,arg))
1963             (when (< n-static-fprs 13)
1964               (static-arg-forms
1965                `(setf (paref ,fpr-base (:* :double-float) ,n-static-fprs)
1966                  (%get-double-float ,gpr-base ,gpr-offset)))
1967               (incf n-static-fprs))
1968             (incf n-static-gprs 1))
1969            (foreign-pointer-type
1970             (static-arg-forms
1971              `(setf (paref ,gpr-base (:* address) ,n-static-gprs) ,arg))
1972             (incf n-static-gprs)))))
1973     
1974      (compile
1975        nil
1976        `(lambda (,receiver ,selector ,@args &rest ,rest-arg)
1977          (declare (dynamic-extent ,rest-arg))
1978          (let* ((,selptr (%get-selector ,selector))
1979                 (,gpr-total (+ ,n-static-gprs (length ,rest-arg))))
1980            (%stack-block ((,fp-arg-ptr (* 8 13)))
1981              (with-variable-c-frame ,gpr-total ,c-frame
1982                (with-macptrs ((,gen-arg-ptr))
1983                  (%setf-macptr-to-object ,gen-arg-ptr (+ ,c-frame (ash ppc64::c-frame.param0 (- ppc64::word-shift))))
1984                  (progn ,@(static-arg-forms))
1985                  (%load-fp-arg-regs (%process-varargs-list ,gen-arg-ptr ,fp-arg-ptr ,n-static-gprs ,n-static-fprs  ,rest-arg) ,fp-arg-ptr)
1986                 
1987                  (%do-ff-call nil (%reference-external-entry-point (load-time-value (external "_objc_msgSend"))))
1988                  ;; Using VALUES here is a hack: the multiple-value
1989                  ;; returning machinery clobbers imm0.
1990                  (values (%%ff-result ,(foreign-type-to-representation-type return-type-spec))))))))))))
1991
1992
1993
1994
1995(defun %compile-send-function-for-signature (sig &optional super-p)
1996  (let* ((return-type-spec (car sig))
1997         (arg-type-specs (cdr sig)))
1998    (if (eq (car (last arg-type-specs)) :void)
1999      (%compile-varargs-send-function-for-signature sig)
2000      (let* ((args (objc-gen-message-arglist (length arg-type-specs)))
2001             (struct-return-var nil)
2002             (receiver (gensym))
2003             (selector (gensym)))
2004        (collect ((call)
2005                  (lets))
2006          (let* ((result-type (parse-foreign-type return-type-spec)))
2007            (when (typep result-type 'foreign-record-type)
2008              (setq struct-return-var (gensym))
2009              (lets `(,struct-return-var (make-gcable-record ,return-type-spec))))
2010
2011            (do ((args args (cdr args))
2012                 (spec (pop arg-type-specs) (pop arg-type-specs)))
2013                ((null args) (call return-type-spec))
2014              (let* ((arg (car args)))
2015                 (call spec)
2016                 (case spec
2017                   (:<BOOL> (call `(%coerce-to-bool ,arg)))
2018                   (:id (call `(%coerce-to-address ,arg)))
2019                   (:<CGF>loat (call `(float ,arg +cgfloat-zero+)))
2020                   (t
2021                    (call arg)))))
2022            (let* ((call (call))
2023                   (lets (lets))
2024                   (body (message-send-form-for-call receiver selector call super-p struct-return-var)))
2025              (if struct-return-var
2026                (setq body `(progn ,body ,struct-return-var)))
2027              (if lets
2028                (setq body `(let* ,lets
2029                             ,body)))
2030              (compile nil
2031                       `(lambda (,receiver ,selector ,@args)
2032                         ,body)))))))))
2033
2034(defun compile-send-function-for-signature (sig)
2035  (%compile-send-function-for-signature sig nil))
2036                           
2037                   
2038
2039
2040;;; The first 8 words of non-fp arguments get passed in R3-R10
2041#+ppc-target
2042(defvar *objc-gpr-offsets*
2043  #+32-bit-target
2044  #(4 8 12 16 20 24 28 32)
2045  #+64-bit-target
2046  #(8 16 24 32 40 48 56 64)
2047  )
2048
2049
2050
2051;;; The first 13 fp arguments get passed in F1-F13 (and also "consume"
2052;;; a GPR or two.)  It's certainly possible for an FP arg and a non-
2053;;; FP arg to share the same "offset", and parameter offsets aren't
2054;;; strictly increasing.
2055#+ppc-target
2056(defvar *objc-fpr-offsets*
2057  #+32-bit-target
2058  #(36 44 52 60  68  76  84  92 100 108 116 124 132)
2059  #+64-bit-target
2060  #(68 76 84 92 100 108 116 124 132 140 148 156 164))
2061
2062;;; Just to make things even more confusing: once we've filled in the
2063;;; first 8 words of the parameter area, args that aren't passed in
2064;;; FP-regs get assigned offsets starting at 32.  That almost makes
2065;;; sense (even though it conflicts with the last offset in
2066;;; *objc-gpr-offsets* (assigned to R10), but we then have to add
2067;;; this constant to the memory offset.
2068(defconstant objc-forwarding-stack-offset 8)
2069
2070(defvar *objc-id-type* (parse-foreign-type :id))
2071(defvar *objc-sel-type* (parse-foreign-type :<SEL>))
2072(defvar *objc-char-type* (parse-foreign-type :char))
2073
2074
2075(defun encode-objc-type (type &optional for-ivar recursive)
2076  (if (or (eq type *objc-id-type*)
2077          (foreign-type-= type *objc-id-type*))
2078    "@"
2079    (if (or (eq type *objc-sel-type*)
2080            (foreign-type-= type *objc-sel-type*))
2081      ":"
2082      (if (eq (foreign-type-class type) 'root)
2083        "v"
2084        (typecase type
2085          (foreign-pointer-type
2086           (let* ((target (foreign-pointer-type-to type)))
2087             (if (or (eq target *objc-char-type*)
2088                     (foreign-type-= target *objc-char-type*))
2089               "*"
2090               (format nil "^~a" (encode-objc-type target nil t)))))
2091          (foreign-double-float-type "d")
2092          (foreign-single-float-type "f")
2093          (foreign-integer-type
2094           (let* ((signed (foreign-integer-type-signed type))
2095                  (bits (foreign-integer-type-bits type)))
2096             (if (eq (foreign-integer-type-alignment type) 1)
2097               (format nil "b~d" bits)
2098               (cond ((= bits 8)
2099                      (if signed "c" "C"))
2100                     ((= bits 16)
2101                      (if signed "s" "S"))
2102                     ((= bits 32)
2103                      ;; Should be some way of noting "longness".
2104                      (if signed "i" "I"))
2105                     ((= bits 64)
2106                      (if signed "q" "Q"))))))
2107          (foreign-record-type
2108           (ensure-foreign-type-bits type)
2109           (let* ((name (unescape-foreign-name
2110                         (or (foreign-record-type-name type) "?")))
2111                  (kind (foreign-record-type-kind type))
2112                  (fields (foreign-record-type-fields type)))
2113             (with-output-to-string (s)
2114                                    (format s "~c~a=" (if (eq kind :struct) #\{ #\() name)
2115                                    (dolist (f fields (format s "~a" (if (eq kind :struct) #\} #\))))
2116                                      (when for-ivar
2117                                        (format s "\"~a\""
2118                                                (unescape-foreign-name
2119                                                 (or (foreign-record-field-name f) ""))))
2120                                      (unless recursive
2121                                        (format s "~a" (encode-objc-type
2122                                                        (foreign-record-field-type f) nil nil)))))))
2123        (foreign-array-type
2124           (ensure-foreign-type-bits type)
2125           (let* ((dims (foreign-array-type-dimensions type))
2126                  (element-type (foreign-array-type-element-type type)))
2127             (if dims (format nil "[~d~a]"
2128                              (car dims)
2129                              (encode-objc-type element-type nil t))
2130               (if (or (eq element-type *objc-char-type*)
2131                       (foreign-type-= element-type *objc-char-type*))
2132                 "*"
2133                 (format nil "^~a" (encode-objc-type element-type nil t))))))
2134          (t (break "type = ~s" type)))))))
2135
2136#+ppc-target
2137(defun encode-objc-method-arglist (arglist result-spec)
2138  (let* ((gprs-used 0)
2139         (fprs-used 0)
2140         (arg-info
2141          (flet ((current-memory-arg-offset ()
2142                   (+ 32 (* 4 (- gprs-used 8))
2143                      objc-forwarding-stack-offset)))
2144            (flet ((current-gpr-arg-offset ()
2145                     (if (< gprs-used 8)
2146                       (svref *objc-gpr-offsets* gprs-used)
2147                       (current-memory-arg-offset)))
2148                   (current-fpr-arg-offset ()
2149                     (if (< fprs-used 13)
2150                       (svref *objc-fpr-offsets* fprs-used)
2151                       (current-memory-arg-offset))))
2152              (let* ((result nil))
2153                (dolist (argspec arglist (nreverse result))
2154                  (let* ((arg (parse-foreign-type argspec))
2155                         (offset 0)
2156                         (size 0))
2157                    (typecase arg
2158                      (foreign-double-float-type
2159                       (setq size 8 offset (current-fpr-arg-offset))
2160                       (incf fprs-used)
2161                       (incf gprs-used 2))
2162                      (foreign-single-float-type
2163                       (setq size target::node-size offset (current-fpr-arg-offset))
2164                       (incf fprs-used)
2165                       (incf gprs-used 1))
2166                      (foreign-pointer-type
2167                       (setq size target::node-size offset (current-gpr-arg-offset))
2168                       (incf gprs-used))
2169                      (foreign-integer-type
2170                       (let* ((bits (foreign-type-bits arg)))
2171                         (setq size (ceiling bits 8)
2172                               offset (current-gpr-arg-offset))
2173                         (incf gprs-used (ceiling bits target::nbits-in-word))))
2174                      ((or foreign-record-type foreign-array-type)
2175                       (let* ((bits (ensure-foreign-type-bits arg)))
2176                         (setq size (ceiling bits 8)
2177                               offset (current-gpr-arg-offset))
2178                         (incf gprs-used (ceiling bits target::nbits-in-word))))
2179                      (t (break "argspec = ~s, arg = ~s" argspec arg)))
2180                    (push (list (encode-objc-type arg) offset size) result))))))))
2181    (declare (fixnum gprs-used fprs-used))
2182    (let* ((max-parm-end
2183            (- (apply #'max (mapcar #'(lambda (i) (+ (cadr i) (caddr i)))
2184                                    arg-info))
2185               objc-forwarding-stack-offset)))
2186      (format nil "~a~d~:{~a~d~}"
2187              (encode-objc-type
2188               (parse-foreign-type result-spec))
2189              max-parm-end
2190              arg-info))))
2191
2192#+x86-target
2193(defun encode-objc-method-arglist (arglist result-spec)
2194  (let* ((offset 0)
2195         (arg-info
2196          (let* ((result nil))
2197                (dolist (argspec arglist (nreverse result))
2198                  (let* ((arg (parse-foreign-type argspec))
2199                         (delta target::node-size))
2200                    (typecase arg
2201                      (foreign-double-float-type)
2202                      (foreign-single-float-type)
2203                      ((or foreign-pointer-type foreign-array-type))
2204                      (foreign-integer-type)
2205                      (foreign-record-type
2206                       (let* ((bits (ensure-foreign-type-bits arg)))
2207                         (setq delta (ceiling bits target::node-size))))
2208                      (t (break "argspec = ~s, arg = ~s" argspec arg)))
2209                    (push (list (encode-objc-type arg) offset) result)
2210                    (setq offset (* target::node-size (ceiling (+ offset delta) target::node-size))))))))
2211    (let* ((max-parm-end offset))
2212      (format nil "~a~d~:{~a~d~}"
2213              (encode-objc-type
2214               (parse-foreign-type result-spec))
2215              max-parm-end
2216              arg-info))))
2217
2218;;; In Apple Objc, a class's methods are stored in a (-1)-terminated
2219;;; vector of method lists.  In GNU ObjC, method lists are linked
2220;;; together.
2221(defun %make-method-vector ()
2222  #+apple-objc
2223  (let* ((method-vector (malloc 16)))
2224    (setf (%get-signed-long method-vector 0) 0
2225          (%get-signed-long method-vector 4) 0
2226          (%get-signed-long method-vector 8) 0
2227          (%get-signed-long method-vector 12) -1)
2228    method-vector))
2229
2230
2231;;; Make a meta-class object (with no instance variables or class
2232;;; methods.)
2233#-apple-objc-2.0
2234(defun %make-basic-meta-class (nameptr superptr rootptr)
2235  #+apple-objc
2236  (let* ((method-vector (%make-method-vector)))
2237    (make-record :objc_class
2238                 :isa (pref rootptr :objc_class.isa)
2239                 :super_class (pref superptr :objc_class.isa)
2240                 :name nameptr
2241                 :version 0
2242                 :info #$CLS_META
2243                 :instance_size 0
2244                 :ivars (%null-ptr)
2245                 :method<L>ists method-vector
2246                 :cache (%null-ptr)
2247                 :protocols (%null-ptr)))
2248  #+gnu-objc
2249  (make-record :objc_class
2250               :class_pointer (pref rootptr :objc_class.class_pointer)
2251               :super_class (pref superptr :objc_class.class_pointer)
2252               :name nameptr
2253               :version 0
2254               :info #$_CLS_META
2255               :instance_size 0
2256               :ivars (%null-ptr)
2257               :methods (%null-ptr)
2258               :dtable (%null-ptr)
2259               :subclass_list (%null-ptr)
2260               :sibling_class (%null-ptr)
2261               :protocols (%null-ptr)
2262               :gc_object_type (%null-ptr)))
2263
2264#-apple-objc-2.0
2265(defun %make-class-object (metaptr superptr nameptr ivars instance-size)
2266  #+apple-objc
2267  (let* ((method-vector (%make-method-vector)))
2268    (make-record :objc_class
2269                 :isa metaptr
2270                 :super_class superptr
2271                 :name nameptr
2272                 :version 0
2273                 :info #$CLS_CLASS
2274                 :instance_size instance-size
2275                 :ivars ivars
2276                 :method<L>ists method-vector
2277                 :cache (%null-ptr)
2278                 :protocols (%null-ptr)))
2279  #+gnu-objc
2280  (make-record :objc_class
2281                 :class_pointer metaptr
2282                 :super_class superptr
2283                 :name nameptr
2284                 :version 0
2285                 :info #$_CLS_CLASS
2286                 :instance_size instance-size
2287                 :ivars ivars
2288                 :methods (%null-ptr)
2289                 :dtable (%null-ptr)
2290                 :protocols (%null-ptr)))
2291
2292(defun make-objc-class-pair (superptr nameptr)
2293  #+apple-objc-2.0
2294  (#_objc_allocateClassPair superptr nameptr 0)
2295  #-apple-objc-2.0
2296  (%make-class-object
2297   (%make-basic-meta-class nameptr superptr (@class "NSObject"))
2298   superptr
2299   nameptr
2300   (%null-ptr)
2301   0))
2302
2303(defun superclass-instance-size (class)
2304  (with-macptrs ((super #+apple-objc-2.0 (#_class_getSuperclass class)
2305                        #-apple-objc-2.0 (pref class :objc_class.super_class)))
2306    (if (%null-ptr-p super)
2307      0
2308      (%objc-class-instance-size super))))
2309
2310       
2311
2312
2313#+gnu-objc
2314(progn
2315(defloadvar *gnu-objc-runtime-mutex*
2316    (%get-ptr (foreign-symbol-address "__objc_runtime_mutex")))
2317(defmacro with-gnu-objc-mutex-locked ((mutex) &body body)
2318  (let* ((mname (gensym)))
2319    `(let ((,mname ,mutex))
2320      (unwind-protect
2321           (progn
2322             (external-call "objc_mutex_lock" :address ,mname :void)
2323             ,@body)
2324        (external-call "objc_mutex_lock" :address ,mname :void)))))
2325)
2326
2327(defun %objc-metaclass-p (class)
2328  #+apple-objc-2.0 (not (eql #$NO (#_class_isMetaClass class)))
2329  #-apple-objc-2.0
2330  (logtest (pref class :objc_class.info)
2331           #+apple-objc #$CLS_META
2332           #+gnu-objc #$_CLS_META))
2333
2334;; No way to tell in Objc-2.0.  Does anything care ?
2335#-apple-objc-2.0
2336(defun %objc-class-posing-p (class)
2337  (logtest (pref class :objc_class.info)
2338           #+apple-objc #$CLS_POSING
2339           #+gnu-objc #$_CLS_POSING))
2340
2341
2342
2343
2344;;; Create (malloc) class and metaclass objects with the specified
2345;;; name (string) and superclass name.  Initialize the metaclass
2346;;; instance, but don't install the class in the ObjC runtime system
2347;;; (yet): we don't know anything about its ivars and don't know
2348;;; how big instances will be yet.
2349;;; If an ObjC class with this name already exists, we're very
2350;;; confused; check for that case and error out if it occurs.
2351(defun %allocate-objc-class (name superptr)
2352  (let* ((class-name (compute-objc-classname name)))
2353    (if (lookup-objc-class class-name nil)
2354      (error "An Objective C class with name ~s already exists." class-name))
2355    (let* ((nameptr (make-cstring class-name))
2356           (id (register-objc-class
2357                (make-objc-class-pair superptr nameptr)
2358))
2359           (meta-id (objc-class-id->objc-metaclass-id id))
2360           (meta (id->objc-metaclass meta-id))
2361           (class (id->objc-class id))
2362           (meta-name (intern (format nil "+~a" name)
2363                              (symbol-package name)))
2364           (meta-super (canonicalize-registered-metaclass
2365                        #+apple-objc-2.0
2366                        (#_class_getSuperclass meta)
2367                        #-apple-objc-2.0
2368                        (pref meta :objc_class.super_class))))
2369      (initialize-instance meta
2370                         :name meta-name
2371                         :direct-superclasses (list meta-super))
2372      (setf (objc-class-id-foreign-name id) class-name
2373            (objc-metaclass-id-foreign-name meta-id) class-name
2374            (find-class meta-name) meta)
2375      (%defglobal name class)
2376      (%defglobal meta-name meta)
2377    class)))
2378
2379;;; Set up the class's ivar_list and instance_size fields, then
2380;;; add the class to the ObjC runtime.
2381#-apple-objc-2.0
2382(defun %add-objc-class (class ivars instance-size)
2383  (setf
2384   (pref class :objc_class.ivars) ivars
2385   (pref class :objc_class.instance_size) instance-size)
2386  #+apple-objc
2387  (#_objc_addClass class)
2388  #+gnu-objc
2389  ;; Why would anyone want to create a class without creating a Module ?
2390  ;; Rather than ask that vexing question, let's create a Module with
2391  ;; one class in it and use #___objc_exec_class to add the Module.
2392  ;; (I mean "... to add the class", of course.
2393  ;; It appears that we have to heap allocate the module, symtab, and
2394  ;; module name: the GNU ObjC runtime wants to add the module to a list
2395  ;; that it subsequently ignores.
2396  (let* ((name (make-cstring "Phony Module"))
2397         (symtab (malloc (+ (record-length :objc_symtab) (record-length (:* :void)))))
2398         (m (make-record :objc_module
2399                         :version 8 #|OBJC_VERSION|#
2400                         :size (record-length :<M>odule)
2401                         :name name
2402                         :symtab symtab)))
2403    (setf (%get-ptr symtab (record-length :objc_symtab)) (%null-ptr))
2404    (setf (pref symtab :objc_symtab.sel_ref_cnt) 0
2405          (pref symtab :objc_symtab.refs) (%null-ptr)
2406          (pref symtab :objc_symtab.cls_def_cnt) 1
2407          (pref symtab :objc_symtab.cat_def_cnt) 0
2408          (%get-ptr (pref symtab :objc_symtab.defs)) class
2409          (pref class :objc_class.info) (logior #$_CLS_RESOLV (pref class :objc_class.info)))
2410    (#___objc_exec_class m)))
2411
2412#+apple-objc-2.0
2413(defun %add-objc-class (class)
2414  (#_objc_registerClassPair class))
2415
2416
2417
2418
2419
2420
2421
2422(let* ((objc-gen-message-args (make-array 10 :fill-pointer 0 :adjustable t)))
2423  (defun %objc-gen-message-arg (n)
2424    (let* ((len (length objc-gen-message-args)))
2425      (do* ((i len (1+ i)))
2426           ((> i n) (aref objc-gen-message-args n))
2427        (vector-push-extend (intern (format nil "ARG~d" i)) objc-gen-message-args)))))
2428
2429(defun objc-gen-message-arglist (n)
2430  (collect ((args))
2431    (dotimes (i n (args)) (args (%objc-gen-message-arg i)))))
2432
2433
2434
2435;;; Call get-objc-message-info for all known init messages.  (A
2436;;; message is an "init message" if it starts with the string "init",
2437;;; and has at least one declared method that returns :ID and is not a
2438;;; protocol method.
2439(defun register-objc-init-messages ()
2440  (do-interface-dirs (d)
2441    (dolist (init (cdb-enumerate-keys (db-objc-methods d)
2442                                      #'(lambda (string)
2443                                          (string= string "init" :end1 (min (length string) 4)))))
2444      (get-objc-message-info init))))
2445
2446   
2447(defvar *objc-init-messages-for-init-keywords* (make-hash-table :test #'equal)
2448  "Maps from lists of init keywords to dispatch-functions for init messages")
2449
2450
2451
2452(defun send-objc-init-message (instance init-keywords args)
2453  (let* ((info (gethash init-keywords *objc-init-messages-for-init-keywords*)))
2454    (unless info
2455      (let* ((name (lisp-to-objc-init init-keywords))
2456             (name-info (get-objc-message-info name nil)))
2457        (unless name-info
2458          (error "Unknown ObjC init message: ~s" name))
2459        (setf (gethash init-keywords *objc-init-messages-for-init-keywords*)
2460              (setq info name-info))))
2461    (apply (objc-message-info-lisp-name info) instance args)))
2462                   
2463
2464 
2465
2466                 
2467
2468;;; Return the "canonical" version of P iff it's a known ObjC class
2469(defun objc-class-p (p)
2470  (if (typep p 'macptr)
2471    (let* ((id (objc-class-id p)))
2472      (if id (id->objc-class id)))))
2473
2474;;; Return the canonical version of P iff it's a known ObjC metaclass
2475(defun objc-metaclass-p (p)
2476  (if (typep p 'macptr)
2477    (let* ((id (objc-metaclass-id p)))
2478      (if id (id->objc-metaclass id)))))
2479
2480;;; If P is an ObjC instance, return a pointer to its class.
2481;;; This assumes that all instances are allocated via something that's
2482;;; ultimately malloc-based.
2483(defun objc-instance-p (p)
2484  (when (typep p 'macptr)
2485    (let* ((idx (%objc-instance-class-index p)))
2486      (if idx (id->objc-class  idx)))))
2487
2488
2489
2490
2491(defun objc-private-class-id (classptr)
2492  (let* ((info (%get-private-objc-class classptr)))
2493    (when info
2494      (or (private-objc-class-info-declared-ancestor info)
2495          (with-macptrs ((super #+apple-objc-2.0 (#_class_getSuperclass classptr)
2496                                #-apple-objc-2.0 (pref classptr :objc_class.super_class)))
2497            (loop
2498              (when (%null-ptr-p super)
2499                (return))
2500              (let* ((id (objc-class-id super)))
2501                (if id
2502                  (return (setf (private-objc-class-info-declared-ancestor info)
2503                                id))
2504                  (%setf-macptr super #+apple-objc-2.0 (#_class_getSuperclass super)
2505                                #-apple-objc-2.0 (pref super :objc_class.super_class))))))))))
2506
2507(defun objc-class-or-private-class-id (classptr)
2508  (or (objc-class-id classptr)
2509      (objc-private-class-id classptr)))
2510
2511
2512(defun %objc-instance-class-index (p)
2513  (unless (%null-ptr-p p)
2514    (if (with-macptrs (q)
2515          (safe-get-ptr p q)
2516          (not (%null-ptr-p q)))
2517      (with-macptrs ((parent #+apple-objc (pref p :objc_object.isa)
2518                             #+gnu-objc (pref p :objc_object.class_pointer)))
2519        (or
2520         (objc-class-id parent)
2521         (objc-private-class-id parent))))))
2522
2523
2524;;; If an instance, return (values :INSTANCE <class>)
2525;;; If a class, return (values :CLASS <class>).
2526;;; If a metaclass, return (values :METACLASS <metaclass>).
2527;;; Else return (values NIL NIL).
2528(defun objc-object-p (p)
2529  (let* ((instance-p (objc-instance-p p)))
2530    (if instance-p
2531      (values :instance instance-p)
2532      (let* ((class-p (objc-class-p p)))
2533        (if class-p
2534          (values :class class-p)
2535          (let* ((metaclass-p (objc-metaclass-p p)))
2536            (if metaclass-p
2537              (values :metaclass metaclass-p)
2538              (values nil nil))))))))
2539
2540       
2541
2542
2543
2544;;; If the class contains an mlist that contains a method that
2545;;; matches (is EQL to) the selector, remove the mlist and
2546;;; set its IMP; return the containing mlist.
2547;;; If the class doesn't contain any matching mlist, create
2548;;; an mlist with one method slot, initialize the method, and
2549;;; return the new mlist.  Doing it this way ensures
2550;;; that the objc runtime will invalidate any cached references
2551;;; to the old IMP, at least as far as objc method dispatch is
2552;;; concerned.
2553#-apple-objc-2.0
2554(defun %mlist-containing (classptr selector typestring imp)
2555  #-apple-objc (declare (ignore classptr selector typestring imp))
2556  #+apple-objc
2557  (%stack-block ((iter 4))
2558    (setf (%get-ptr iter) (%null-ptr))
2559    (loop
2560        (let* ((mlist (#_class_nextMethodList classptr iter)))
2561          (when (%null-ptr-p mlist)
2562            (let* ((mlist (make-record :objc_method_list
2563                                       :method_count 1))
2564                   (method (pref mlist :objc_method_list.method_list)))
2565              (setf (pref method :objc_method.method_name) selector
2566                    (pref method :objc_method.method_types)
2567                    (make-cstring typestring)
2568                    (pref method :objc_method.method_imp) imp)
2569              (return mlist)))
2570          (do* ((n (pref mlist :objc_method_list.method_count))
2571                (i 0 (1+ i))
2572                (method (pref mlist :objc_method_list.method_list)
2573                        (%incf-ptr method (record-length :objc_method))))
2574               ((= i n))
2575            (declare (fixnum i n))
2576            (when (eql selector (pref method :objc_method.method_name))
2577              (#_class_removeMethods classptr mlist)
2578              (setf (pref method :objc_method.method_imp) imp)
2579              (return-from %mlist-containing mlist)))))))
2580             
2581
2582(defun %add-objc-method (classptr selector typestring imp)
2583  #+apple-objc-2.0
2584  (with-cstrs ((typestring typestring))
2585    (or (not (eql #$NO (#_class_addMethod classptr selector imp typestring)))
2586        (let* ((m (if (objc-metaclass-p classptr)
2587                    (#_class_getClassMethod classptr selector)
2588                    (#_class_getInstanceMethod classptr selector))))
2589          (if (not (%null-ptr-p m))
2590            (#_method_setImplementation m imp)
2591            (error "Can't add ~s method to class ~s" selector typestring)))))
2592  #-apple-objc-2.0
2593  (progn
2594    #+apple-objc
2595    (#_class_addMethods classptr
2596                        (%mlist-containing classptr selector typestring imp))
2597    #+gnu-objc
2598  ;;; We have to do this ourselves, and have to do it with the runtime
2599  ;;; mutex held.
2600    (with-gnu-objc-mutex-locked (*gnu-objc-runtime-mutex*)
2601      (let* ((ctypestring (make-cstring typestring))
2602             (new-mlist nil))
2603        (with-macptrs ((method (external-call "search_for_method_in_list"
2604                                              :address (pref classptr :objc_class.methods)
2605                                              :address selector
2606                                              :address)))
2607          (when (%null-ptr-p method)
2608            (setq new-mlist (make-record :objc_method_list :method_count 1))
2609            (%setf-macptr method (pref new-mlist :objc_method_list.method_list)))
2610          (setf (pref method :objc_method.method_name) selector
2611                (pref method :objc_method.method_types) ctypestring
2612                (pref method :objc_method.method_imp) imp)
2613          (if new-mlist
2614            (external-call "GSObjCAddMethods"
2615                           :address classptr
2616                           :address new-mlist
2617                           :void)
2618            (external-call "__objc_update_dispatch_table_for_class"
2619                           :address classptr
2620                           :void)))))))
2621
2622(defvar *lisp-objc-methods* (make-hash-table :test #'eq))
2623
2624(defstruct lisp-objc-method
2625  class-descriptor
2626  sel
2627  typestring
2628  class-p                               ;t for class methods
2629  imp                                   ; callback ptr
2630  )
2631
2632(defun %add-lisp-objc-method (m)
2633  (let* ((class (%objc-class-classptr (lisp-objc-method-class-descriptor m)))
2634         (sel (%get-selector (lisp-objc-method-sel m)))
2635         (typestring (lisp-objc-method-typestring m))
2636         (imp (lisp-objc-method-imp m)))
2637    (%add-objc-method
2638     (if (lisp-objc-method-class-p m)
2639       (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer)
2640       class)
2641     sel
2642     typestring
2643     imp)))
2644
2645(def-ccl-pointers add-objc-methods ()
2646  (maphash #'(lambda (impname m)
2647               (declare (ignore impname))
2648               (%add-lisp-objc-method m))
2649           *lisp-objc-methods*))
2650
2651(defun %define-lisp-objc-method (impname classname selname typestring imp
2652                                         &optional class-p)
2653  (%add-lisp-objc-method
2654   (setf (gethash impname *lisp-objc-methods*)
2655         (make-lisp-objc-method
2656          :class-descriptor (load-objc-class-descriptor classname)
2657          :sel (load-objc-selector selname)
2658          :typestring typestring
2659          :imp imp
2660          :class-p class-p)))
2661  impname)
2662   
2663
2664
2665
2666
2667;;; If any of the argspecs denote a value of type :<BOOL>, push an
2668;;; appropriate SETQ on the front of the body.  (Order doesn't matter.)
2669(defun coerce-foreign-boolean-args (argspecs body)
2670  (do* ((argspecs argspecs (cddr argspecs))
2671        (type (car argspecs) (car argspecs))
2672        (var (cadr argspecs) (cadr argspecs)))
2673       ((null argspecs) body)
2674    (when (eq type :<BOOL>)
2675      (push `(setq ,var (not (eql ,var 0))) body))))
2676     
2677(defun lisp-boolean->foreign-boolean (form)
2678  (let* ((val (gensym)))
2679    `((let* ((,val (progn ,@form)))
2680        (if (and ,val (not (eql 0 ,val))) 1 0)))))
2681
2682;;; Return, as multiple values:
2683;;;  the selector name, as a string
2684;;;  the ObjC class name, as a string
2685;;;  the foreign result type
2686;;;  the foreign argument type/argument list
2687;;;  the body
2688;;;  a string which encodes the foreign result and argument types
2689(defun parse-objc-method (selector-arg class-arg body)
2690  (let* ((class-name (objc-class-name-string class-arg))
2691         (selector-form selector-arg)
2692         (selector nil)
2693         (argspecs nil)
2694         (resulttype nil)
2695         (struct-return nil))
2696    (flet ((bad-selector (why) (error "Can't parse method selector ~s : ~a"
2697                                   selector-arg why)))
2698      (typecase selector-form
2699        (string
2700         (let* ((specs (pop body)))
2701             (setq selector selector-form)
2702             (if (evenp (length specs))
2703               (setq argspecs specs resulttype :id)
2704               (setq resulttype (car (last specs))
2705                     argspecs (butlast specs)))))
2706        (cons                           ;sic
2707         (setq resulttype (pop selector-form))
2708         (unless (consp selector-form)
2709           (bad-selector "selector-form not a cons"))
2710         (ccl::collect ((components)
2711                         (specs))
2712           ;; At this point, selector-form should be either a list of
2713           ;; a single symbol (a lispified version of the selector name
2714           ;; of a selector that takes no arguments) or a list of keyword/
2715           ;; variable pairs.  Each keyword is a lispified component of
2716           ;; the selector name; each "variable" is either a symbol
2717           ;; or a list of the form (<foreign-type> <symbol>), where
2718           ;; an atomic variable is shorthand for (:id <symbol>).
2719           (if (and (null (cdr selector-form))
2720                    (car selector-form)
2721                    (typep (car selector-form) 'symbol)
2722                    (not (typep (car selector-form) 'keyword)))
2723             (components (car selector-form))
2724             (progn
2725               (unless (evenp (length selector-form))
2726                 (bad-selector "Odd length"))
2727               (do* ((s selector-form (cddr s))
2728                     (comp (car s) (car s))
2729                     (var (cadr s) (cadr s)))
2730                    ((null s))
2731                 (unless (typep comp 'keyword) (bad-selector "not a keyword"))
2732                 (components comp)
2733                 (cond ((atom var)
2734                        (unless (and var (symbolp var))
2735                          (bad-selector "not a non-null symbol"))
2736                        (specs :id)
2737                        (specs var))
2738                       ((and (consp (cdr var))
2739                             (null (cddr var))
2740                             (cadr var)
2741                             (symbolp (cadr var)))
2742                        (specs (car var))
2743                        (specs (cadr var)))
2744                       (t (bad-selector "bad variable/type clause"))))))
2745           (setq argspecs (specs)
2746                 selector (lisp-to-objc-message (components)))))
2747        (t (bad-selector "general failure")))
2748      ;; If the result type is of the form (:STRUCT <typespec> <name>),
2749      ;; make <name> be the first argument.
2750      (when (and (consp resulttype)
2751                 (eq (car resulttype) :struct))
2752        (destructuring-bind (typespec name) (cdr resulttype)
2753          (let* ((rtype (%foreign-type-or-record typespec)))
2754            (if (and (typep name 'symbol)
2755                     (typep rtype 'foreign-record-type))
2756              (setq struct-return name
2757                    resulttype (unparse-foreign-type rtype))
2758              (bad-selector "Bad struct return type")))))
2759      (values selector
2760              class-name
2761              resulttype
2762              argspecs
2763              body
2764              (do* ((argtypes ())
2765                    (argspecs argspecs (cddr argspecs)))
2766                   ((null argspecs) (encode-objc-method-arglist
2767                                     `(:id :<sel> ,@(nreverse argtypes))
2768                                     resulttype))
2769                (push (car argspecs) argtypes))
2770              struct-return))))
2771
2772(defun objc-method-definition-form (class-p selector-arg class-arg body env)
2773  (multiple-value-bind (selector-name
2774                        class-name
2775                        resulttype
2776                        argspecs
2777                        body
2778                        typestring
2779                        struct-return)
2780      (parse-objc-method selector-arg class-arg body)
2781    (%declare-objc-method selector-name
2782                          class-name
2783                          class-p
2784                          (concise-foreign-type resulttype)
2785                          (collect ((argtypes))
2786                            (do* ((argspecs argspecs (cddr argspecs)))
2787                                 ((null argspecs) (mapcar #'concise-foreign-type (argtypes)))
2788                              (argtypes (car argspecs)))))
2789    (let* ((self (intern "SELF")))
2790      (multiple-value-bind (body decls) (parse-body body env)
2791        (unless class-p
2792          (push `(%set-objc-instance-type ,self) body))
2793        (setq body (coerce-foreign-boolean-args argspecs body))
2794        (if (eq resulttype :<BOOL>)
2795          (setq body (lisp-boolean->foreign-boolean body)))
2796        (let* ((impname (intern (format nil "~c[~a ~a]"
2797                                        (if class-p #\+ #\-)
2798                                        class-name
2799                                        selector-name)))
2800               (_cmd (intern "_CMD"))
2801               (super (gensym "SUPER"))
2802               (params `(:id ,self :<sel> ,_cmd)))
2803          (when struct-return
2804            (push struct-return params))
2805          (setq params (nconc params argspecs))
2806          `(progn
2807            (defcallback ,impname
2808                (:without-interrupts nil
2809                 #+(and openmcl-native-threads apple-objc) :error-return
2810                 #+(and openmcl-native-threads apple-objc)  (condition objc-callback-error-return) ,@params ,resulttype)
2811              (declare (ignorable ,_cmd))
2812              ,@decls
2813              (rlet ((,super :objc_super
2814                       #+apple-objc :receiver #+gnu-objc :self ,self
2815                       #+apple-objc-2.0 :super_class #-apple-objc-2.0 :class
2816                       ,@(if class-p
2817                             #+apple-objc-2.0
2818                             `((external-call "_class_getSuperclass"
2819                                :address (pref (@class ,class-name) :objc_class.isa) :address))
2820                             #-apple-objc-2.0
2821                             `((pref
2822                                (pref (@class ,class-name)
2823                                 #+apple-objc :objc_class.isa
2824                                 #+gnu-objc :objc_class.class_pointer)
2825                                :objc_class.super_class))
2826                             #+apple-objc-2.0
2827                             `((external-call "_class_getSuperclass"
2828                                :address (@class ,class-name) :address))
2829                             #-apple-objc-2.0
2830                             `((pref (@class ,class-name) :objc_class.super_class)))))
2831                (macrolet ((send-super (msg &rest args &environment env) 
2832                             (make-optimized-send nil msg args env nil ',super ,class-name))
2833                           (send-super/stret (s msg &rest args &environment env) 
2834                             (make-optimized-send nil msg args env s ',super ,class-name)))
2835                  ,@body)))
2836            (%define-lisp-objc-method
2837             ',impname
2838             ,class-name
2839             ,selector-name
2840             ,typestring
2841             ,impname
2842             ,class-p)))))))
2843
2844(defmacro define-objc-method ((selector-arg class-arg)
2845                              &body body &environment env)
2846  (objc-method-definition-form nil selector-arg class-arg body env))
2847
2848(defmacro define-objc-class-method ((selector-arg class-arg)
2849                                     &body body &environment env)
2850  (objc-method-definition-form t selector-arg class-arg body env))
2851
2852
2853(declaim (inline %objc-struct-return))
2854
2855(defun %objc-struct-return (return-temp size value)
2856  (unless (eq return-temp value)
2857    (#_bcopy value return-temp size)))
2858
2859(defmacro objc:defmethod (name (self-arg &rest other-args) &body body &environment env)
2860  (collect ((arglist)
2861            (arg-names)
2862            (arg-types)
2863            (bool-args)
2864            (type-assertions))
2865    (let* ((result-type nil)
2866           (struct-return-var nil)
2867           (struct-return-size nil)
2868           (selector nil)
2869           (cmd (intern "_CMD"))
2870           (class-p nil)
2871           (objc-class-name nil))
2872      (if (atom name)
2873        (setq selector (string name) result-type :id)
2874        (setq selector (string (car name)) result-type (concise-foreign-type (or (cadr name) :id))))
2875      (destructuring-bind (self-name lisp-class-name) self-arg
2876        (arg-names self-name)
2877        (arg-types :id)
2878        ;; Hack-o-rama
2879        (let* ((lisp-class-name (string lisp-class-name)))
2880          (if (eq (schar lisp-class-name 0) #\+)
2881            (setq class-p t lisp-class-name (subseq lisp-class-name 1)))
2882          (setq objc-class-name (lisp-to-objc-classname lisp-class-name)))
2883        (let* ((rtype (parse-foreign-type result-type)))
2884          (when (typep rtype 'foreign-record-type)
2885            (setq struct-return-var (gensym))
2886            (setq struct-return-size (ceiling (foreign-type-bits rtype) 8))
2887            (arglist struct-return-var)))
2888        (arg-types :<SEL>)
2889        (arg-names cmd)
2890        (dolist (arg other-args)
2891          (if (atom arg)
2892            (progn
2893              (arg-types :id)
2894              (arg-names arg))
2895            (destructuring-bind (arg-name arg-type) arg
2896              (let* ((concise-type (concise-foreign-type arg-type)))
2897                (unless (eq concise-type :id)
2898                  (let* ((ftype (parse-foreign-type concise-type)))
2899                    (if (typep ftype 'foreign-pointer-type)
2900                      (setq ftype (foreign-pointer-type-to ftype)))
2901                    (if (and (typep ftype 'foreign-record-type)
2902                             (foreign-record-type-name ftype))
2903                      (type-assertions `(%set-macptr-type ,arg-name
2904                                         (foreign-type-ordinal (load-time-value (%foreign-type-or-record ,(foreign-record-type-name ftype)))))))))
2905                (arg-types concise-type)
2906                (arg-names arg-name)))))
2907        (let* ((arg-names (arg-names))
2908               (arg-types (arg-types)))
2909          (do* ((names arg-names)
2910                (types arg-types))
2911               ((null types) (arglist result-type))
2912            (let* ((name (pop names))
2913                   (type (pop types)))
2914              (arglist type)
2915              (arglist name)
2916              (if (eq type :<BOOL>)
2917                (bool-args `(setq ,name (not (eql ,name 0)))))))
2918          (let* ((impname (intern (format nil "~c[~a ~a]"
2919                                          (if class-p #\+ #\-)
2920                                          objc-class-name
2921                                          selector)))
2922                 (typestring (encode-objc-method-arglist arg-types result-type))
2923                 (signature (cons result-type (cddr arg-types))))
2924            (multiple-value-bind (body decls) (parse-body body env)
2925             
2926              (setq body `((progn ,@(bool-args) ,@(type-assertions) ,@body)))
2927              (if (eq result-type :<BOOL>)
2928                (setq body `((%coerce-to-bool ,@body))))
2929              (when struct-return-var
2930                (setq body `((%objc-struct-return ,struct-return-var ,struct-return-size ,@body)))
2931                (setq body `((flet ((struct-return-var-function ()
2932                                      ,struct-return-var))
2933                               (declaim (inline struct-return-var-function))
2934                               ,@body)))
2935                (setq body `((macrolet ((objc:returning-foreign-struct ((var) &body body)
2936                                          `(let* ((,var (struct-return-var-function)))
2937                                            ,@body)))
2938                               ,@body))))
2939              (setq body `((flet ((call-next-method (&rest args)
2940                                  (declare (dynamic-extent args))
2941                                  (apply (function ,(if class-p
2942                                                        '%call-next-objc-class-method
2943                                                        '%call-next-objc-method))
2944                                         ,self-name
2945                                         (@class ,objc-class-name)
2946                                         (@selector ,selector)
2947                                         ',signature
2948                                         args)))
2949                                 (declare (inline call-next-method))
2950                                 ,@body)))
2951              `(progn
2952                (%declare-objc-method
2953                 ',selector
2954                 ',objc-class-name
2955                 ,class-p
2956                 ',result-type
2957                 ',(cddr arg-types))
2958                (defcallback ,impname ( :error-return (condition objc-callback-error-return) ,@(arglist))
2959                  (declare (ignorable ,self-name ,cmd)
2960                           (unsettable ,self-name)
2961                           ,@(unless class-p `((type ,lisp-class-name ,self-name))))
2962                  ,@decls
2963                  ,@body)
2964                (%define-lisp-objc-method
2965                 ',impname
2966                 ,objc-class-name
2967                 ,selector
2968                 ,typestring
2969                 ,impname
2970                 ,class-p)))))))))
2971
2972     
2973           
2974 
2975
2976(defun class-get-instance-method (class sel)
2977  #+apple-objc (#_class_getInstanceMethod class sel)
2978  #+gnu-objc (#_class_get_instance_method class sel))
2979
2980(defun class-get-class-method (class sel)
2981  #+apple-objc (#_class_getClassMethod class sel)
2982  #+gnu-objc   (#_class_get_class_method class sel))
2983
2984(defun method-get-number-of-arguments (m)
2985  #+apple-objc (#_method_getNumberOfArguments m)
2986  #+gnu-objc (#_method_get_number_of_arguments m))
2987
2988#+(and apple-objc (not apple-objc-2.0) ppc-target)
2989(progn
2990(defloadvar *original-deallocate-hook*
2991        #&_dealloc)
2992
2993(defcallback deallocate-nsobject (:address obj :int)
2994  (unless (%null-ptr-p obj)
2995    (remhash obj *objc-object-slot-vectors*))
2996  (ff-call *original-deallocate-hook* :address obj :int))
2997
2998(defun install-lisp-deallocate-hook ()
2999  (setf #&_dealloc deallocate-nsobject))
3000
3001#+later
3002(def-ccl-pointers install-deallocate-hook ()
3003  (install-lisp-deallocate-hook))
3004
3005(defun uninstall-lisp-deallocate-hook ()
3006  (clrhash *objc-object-slot-vectors*)
3007  (setf #&_dealloc *original-deallocate-hook*))
3008
3009(pushnew #'uninstall-lisp-deallocate-hook *save-exit-functions* :test #'eq
3010         :key #'function-name)
3011)
3012
3013 
3014
3015
3016
3017(defloadvar *nsstring-newline* #@"
3018")
3019
3020
3021;;; Execute BODY with an autorelease pool
3022
3023(defmacro with-autorelease-pool (&body body)
3024  (let ((pool-temp (gensym)))
3025    `(let ((,pool-temp (create-autorelease-pool)))
3026      (unwind-protect
3027           (progn ,@body)
3028        (release-autorelease-pool ,pool-temp)))))
3029
3030
3031(defun %make-nsstring (string)
3032  (with-encoded-cstrs :utf-8 ((s string))
3033    (%make-nsstring-from-utf8-c-string s)))
3034
3035
3036
3037#+apple-objc-2.0
3038;;; New!!! Improved!!! At best, half-right!!!
3039(defmacro with-ns-exceptions-as-errors (&body body)
3040  `(progn ,@body))
3041                 
3042             
3043   
3044#-apple-objc-2.0
3045(defmacro with-ns-exceptions-as-errors (&body body)
3046  #+apple-objc
3047  (let* ((nshandler (gensym))
3048         (cframe (gensym)))
3049    `(rletZ ((,nshandler :<NSH>andler2))
3050      (unwind-protect
3051           (progn
3052             (external-call "__NSAddHandler2" :address ,nshandler :void)
3053             (catch ,nshandler
3054               (with-c-frame ,cframe
3055                 (%associate-jmp-buf-with-catch-frame
3056                  ,nshandler
3057                  (%fixnum-ref (%current-tcr) target::tcr.catch-top)
3058                  ,cframe)
3059                 (progn
3060                   ,@body))))
3061        (check-ns-exception ,nshandler))))
3062  #+gnu-objc
3063  `(progn ,@body)
3064  )
3065
3066
3067
3068
3069
3070#+(and apple-objc (not apple-objc-2.0))
3071(defun check-ns-exception (nshandler)
3072  (with-macptrs ((exception (external-call "__NSExceptionObjectFromHandler2"
3073                                           :address nshandler
3074                                           :address)))
3075    (if (%null-ptr-p exception)
3076      (external-call "__NSRemoveHandler2" :address nshandler :void)
3077      (error (ns-exception->lisp-condition (%inc-ptr exception 0))))))
3078
3079
3080
3081
Note: See TracBrowser for help on using the repository browser.