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

Last change on this file since 11426 was 11426, checked in by gb, 11 years ago

Don't use splay-trees to map objc class pointers to info about them.
We've apparently never been locking around accesses to the
PRIVATE-OBJC-CLASSES map, and just doing a lookup on a splay tree
re-writes the tree. (It seems that the lockup described in ticket:381
has to do with two threads doing lookups - and therefore rewriting
parts of the tree - at the same time.)
Since most runtime accesses to these maps are lookups - and since
lock-free hash-tables provide fast concurrent lookups - use hash-tables
instead.

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