source: branches/objc-gf/ccl/examples/objc-runtime.lisp @ 6059

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

Extend the idea previously used for precompiled INIT messages to all
messages; lazily compile a function which knows how to ff-call each
type signature encountered.

Provide varargs support for Darwin x86-64 (so far); ToDo: others.

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