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

Last change on this file since 12438 was 12438, checked in by gb, 10 years ago

Conditionalize for Cocotron/Win32. Seems to mostly work (except for
some issue related to registering new selectors) and Cocotron issue #331.
Smoke-tested on OSX; seems to be OK, but there's a non-zero chance that
I broke something.

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