source: branches/rme-fpe/objc-bridge/objc-runtime.lisp @ 14091

Last change on this file since 14091 was 13907, checked in by rme, 10 years ago

Fix typo (coctron => cocotron) in objc-method-definition-form (used by
old-style define-objc-method).

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