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

Last change on this file since 7471 was 7471, checked in by rme, 13 years ago

When generating ff-calls to objc methods that have
formal parameters of type CGFloat, coerce the actual
parameter to the appropriate kind of float.

This coercion is not performed for variadic methods

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