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

Last change on this file since 14821 was 14821, checked in by gb, 9 years ago

Move along. Nothing to see here.

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