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

Last change on this file since 11904 was 11904, checked in by rme, 11 years ago

Add @protocol macro.

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