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

Last change on this file since 11389 was 11389, checked in by rme, 12 years ago

%STACK-BLOCK takes a size in bytes, not words.

This error was causing varargs send functions to trash the C stack.

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