source: trunk/ccl/objc-bridge/objc-runtime.lisp @ 7450

Last change on this file since 7450 was 7450, checked in by gb, 13 years ago

When reviving ObjC classes, zero out the class/metaclass pointers of each
class if they were "dead macptrs". We don't want to revive a pointer at
its old address, since that may accidentally conflict with some other
class's current address, causing grief and dispair and much gnashing of
teeth in GDB.

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