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

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

Don't need to define foreign types for NSInteger, etc., now that we
target Leopard.

Don't need Carbon (so use only :cocoa interfaces for both apple-objc
and cocotron-objc).

  • 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 coctron-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.