source: branches/objc-gf/ccl/examples/objc-runtime.lisp @ 6139

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

Things seem to basically be working on darwinppc32. Needs some smoke-testing
on darwinppc64.


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