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

Last change on this file since 13537 was 13067, checked in by rme, 10 years ago

Update copyright notices.

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