source: trunk/ccl/examples/objc-runtime.lisp @ 615

Last change on this file since 615 was 615, checked in by gb, 17 years ago

Uninstall dealloc-hook on *SAVE-EXIT-FUNCTIONS* (run before SAVE-APPLICATION),
not *LISP-CLEANUP-FUNCTIONS* (so slot-vectors stay around during shutdown.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 55.6 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  #+darwinppc-target (pushnew :apple-objc *features*)
26  #+linuxppc-target (pushnew :gnu-objc *features*)
27  #-(or darwinppc-target linuxppc-target)
28  (error "Not sure what ObjC runtime system to use."))
29
30
31(eval-when (:compile-toplevel :load-toplevel :execute)
32  (set-dispatch-macro-character
33   #\#
34   #\@
35   (nfunction
36    |objc-#@-reader|
37    (lambda (stream subchar numarg)
38      (declare (ignore subchar numarg))
39      (let* ((string (read stream)))
40        (check-type string string)
41        `(@ ,string))))))
42
43(eval-when (:compile-toplevel :execute)
44  #+apple-objc
45  (use-interface-dir :cocoa)
46  #+gnu-objc
47  (use-interface-dir :gnustep))
48
49(defpackage "OBJC"
50  (:use)
51  (:export "OBJC-OBJECT" "OBJC-CLASS-OBJECT" "OBJC-CLASS" "OBJC-METACLASS"))
52
53(eval-when (:compile-toplevel :load-toplevel :execute)
54  (require "SPLAY-TREE")
55  (require "NAME-TRANSLATION")
56  (require "PROCESS-OBJC-MODULES")
57  (require "OBJC-CLOS"))
58
59(defloadvar *NSApp* nil )
60
61
62(defun ensure-objc-classptr-resolved (classptr)
63  #+apple-objc (declare (ignore classptr))
64  #+gnu-objc
65  (unless (logtest #$_CLS_RESOLV (pref classptr :objc_class.info))
66    (external-call "__objc_resolve_class_links" :void)))
67
68
69
70
71(let* ((objc-class-map (make-splay-tree #'%ptr-eql
72                                        #'(lambda (x y)
73                                            (< (the (unsigned-byte 32)
74                                                 (%ptr-to-int x))
75                                               (the (unsigned-byte 32)
76                                                 (%ptr-to-int Y))))))
77       (objc-metaclass-map (make-splay-tree #'%ptr-eql
78                                            #'(lambda (x y)
79                                                (< (the (unsigned-byte 32)
80                                                     (%ptr-to-int x))
81                                                   (the (unsigned-byte 32)
82                                                     (%ptr-to-int Y))))))
83       (objc-class-lock (make-lock))
84       (next-objc-class-id 0)
85       (next-objc-metaclass-id 0)
86       (class-table-size 1024)
87       (c (make-array 1024))
88       (m (make-array 1024))
89       (cw (make-array 1024 :initial-element nil))
90       (mw (make-array 1024 :initial-element nil))
91       (csv (make-array 1024))
92       (msv (make-array 1024))
93       (class-id->metaclass-id (make-array 1024 :initial-element nil))
94       (class-foreign-names (make-array 1024))
95       (metaclass-foreign-names (make-array 1024))
96       )
97
98  (flet ((grow-vectors ()
99           (let* ((old-size class-table-size)
100                  (new-size (* 2 old-size)))
101             (declare (fixnum old-size new-size))
102             (macrolet ((extend (v)
103                              `(setq ,v (%extend-vector old-size ,v new-size))))
104                   (extend c)
105                   (extend m)
106                   (extend cw)
107                   (extend mw)
108                   (fill cw nil :start old-size :end new-size)
109                   (fill mw nil :start old-size :end new-size)
110                   (extend csv)
111                   (extend msv)
112                   (extend class-id->metaclass-id)
113                   (fill class-id->metaclass-id nil :start old-size :end new-size)
114                   (extend class-foreign-names)
115                   (extend metaclass-foreign-names))
116             (setq class-table-size new-size))))
117    (flet ((assign-next-class-id ()
118             (let* ((id next-objc-class-id))
119               (if (= (incf next-objc-class-id) class-table-size)
120                 (grow-vectors))
121               id))
122           (assign-next-metaclass-id ()
123             (let* ((id next-objc-metaclass-id))
124               (if (= (incf next-objc-metaclass-id) class-table-size)
125                 (grow-vectors))
126               id)))
127      (defun id->objc-class (i)
128        (svref c i))
129      (defun (setf id->objc-class) (new i)
130        (setf (svref c i) new))
131      (defun id->objc-metaclass (i)
132        (svref m i))
133      (defun (setf id->objc-metaclass) (new i)
134        (setf (svref m i) new))
135      (defun id->objc-class-wrapper (i)
136        (svref cw i))
137      (defun (setf id->objc-class-wrapper) (new i)
138        (setf (svref cw i) new))
139      (defun id->objc-metaclass-wrapper (i)
140        (svref mw i))
141      (defun (setf id->objc-metaclass-wrapper) (new i)
142        (setf (svref mw i) new))
143      (defun id->objc-class-slots-vector (i)
144        (svref csv i))
145      (defun (setf id->objc-class-slots-vector) (new i)
146        (setf (svref csv i) new))
147      (defun id->objc-metaclass-slots-vector (i)
148        (svref msv i))
149      (defun (setf id->objc-metaclass-slots-vector) (new i)
150        (setf (svref msv i) new))
151      (defun objc-class-id-foreign-name (i)
152        (svref class-foreign-names i))
153      (defun (setf objc-class-id-foreign-name) (new i)
154        (setf (svref class-foreign-names i) new))
155      (defun objc-metaclass-id-foreign-name (i)
156        (svref metaclass-foreign-names i))
157      (defun (setf objc-metaclass-id-foreign-name) (new i)
158        (setf (svref metaclass-foreign-names i) new))
159      (defun %clear-objc-class-maps ()
160        (with-lock-grabbed (objc-class-lock)
161          (setf (splay-tree-root objc-class-map) nil
162                (splay-tree-root objc-metaclass-map) nil
163                (splay-tree-count objc-class-map) 0
164                (splay-tree-count objc-metaclass-map) 0)))
165      (flet ((install-objc-metaclass (meta)
166               (or (splay-tree-get objc-metaclass-map meta)
167                   (let* ((id (assign-next-metaclass-id))
168                          (meta (%inc-ptr meta 0)))
169                     (splay-tree-put objc-metaclass-map meta id)
170                     (setf (svref m id) meta
171                           (svref msv id)
172                           (make-objc-metaclass-slots-vector meta))
173                     id))))
174        (defun register-objc-class (class)
175          "ensure that the class is mapped to a small integer and associate a slots-vector with it."
176          (with-lock-grabbed (objc-class-lock)
177            (ensure-objc-classptr-resolved class)
178            (or (splay-tree-get objc-class-map class)
179                (let* ((id (assign-next-class-id))
180                       (class (%inc-ptr class 0))
181                       (meta (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer)))
182                  (splay-tree-put objc-class-map class id)
183                  (setf (svref c id) class
184                        (svref csv id)
185                        (make-objc-class-slots-vector class)
186                        (svref class-id->metaclass-id id)
187                        (install-objc-metaclass meta))
188                  id)))))
189      (defun objc-class-id (class)
190        (with-lock-grabbed (objc-class-lock)
191          (splay-tree-get objc-class-map class)))
192      (defun objc-metaclass-id (meta)
193        (with-lock-grabbed (objc-class-lock)
194          (splay-tree-get objc-metaclass-map meta)))
195      (defun objc-class-id->objc-metaclass-id (class-id)
196        (svref class-id->metaclass-id class-id))
197      (defun objc-class-id->objc-metaclass (class-id)
198        (svref m (svref class-id->metaclass-id class-id)))
199      (defun objc-class-map () objc-class-map)
200      (defun %objc-class-count () next-objc-class-id)
201      (defun objc-metaclass-map () objc-metaclass-map)
202      (defun %objc-metaclass-count () next-objc-metaclass-id))))
203
204(pushnew #'%clear-objc-class-maps *save-exit-functions* :test #'eq
205         :key #'function-name)
206
207(defun do-all-objc-classes (f)
208  (map-splay-tree (objc-class-map) #'(lambda (id)
209                                       (funcall f (id->objc-class id)))))
210
211(defun canonicalize-registered-class (c)
212  (let* ((id (objc-class-id c)))
213    (if id
214      (id->objc-class id)
215      (error "Class ~S isn't recognized." c))))
216
217(defun canonicalize-registered-metaclass (m)
218  (let* ((id (objc-metaclass-id m)))
219    (if id
220      (id->objc-metaclass id)
221      (error "Class ~S isn't recognized." m))))
222
223
224;;; Open shared libs.
225#+darwinppc-target
226(progn
227(defloadvar *cocoa-event-process* *initial-process*)
228
229(defun run-in-cocoa-process-and-wait  (f)
230  (let* ((process *cocoa-event-process*)
231         (success (cons nil nil))
232         (done (make-semaphore)))
233    (process-interrupt process #'(lambda ()
234                                   (unwind-protect
235                                        (progn
236                                          (setf (car success) (funcall f)))
237                                     (signal-semaphore done))))
238    (wait-on-semaphore done)
239    (car success)))
240
241
242(def-ccl-pointers cocoa-framework ()
243  (run-in-cocoa-process-and-wait
244   #'(lambda ()
245       ;; We need to load and "initialize" the CoreFoundation library
246       ;; in the thread that's going to process events.  Looking up a
247       ;; symbol in the library should cause it to be initialized
248       (open-shared-library "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation")
249       (open-shared-library "/System/Library/Frameworks/Cocoa.framework/Cocoa")
250       (let* ((current (#_CFRunLoopGetCurrent))
251              (main (external-call "_CFRunLoopGetMain" :address)))
252         ;; Sadly, it seems that OSX versions > 10.2 only want the
253         ;; main CFRunLoop to be owned by the initial thread.  I
254         ;; suppose that we could try to run the event process on that
255         ;; thread, but that'd require some reorganization.
256         (or
257          (eql current main)
258          (progn (external-call "__CFRunLoopSetCurrent"
259                                :address main)
260                 t))))))
261
262
263(let* ((cfstring-sections (cons 0 nil)))
264  (defun reset-cfstring-sections ()
265    (rplaca cfstring-sections 0)
266    (rplacd cfstring-sections nil))
267  (defun find-cfstring-sections ()
268    (let* ((image-count (#_ _dyld_image_count)))
269      (when (> image-count (car cfstring-sections))
270        (process-section-in-all-libraries
271         #$SEG_DATA
272         "__cfstring"
273         #'(lambda (sectaddr size)
274             (let* ((addr (%ptr-to-int sectaddr))
275                    (limit (+ addr size))
276                    (already (member addr (cdr cfstring-sections) :key #'car)))
277               (if already
278                 (rplacd already limit)
279                 (push (cons addr limit) (cdr cfstring-sections))))))
280        (setf (car cfstring-sections) image-count))))
281  (defun pointer-in-cfstring-section-p (ptr)
282    (let* ((addr (%ptr-to-int ptr)))
283      (dolist (s (cdr cfstring-sections))
284        (when (and (>= addr (car s))
285                   (< addr (cdr s)))
286          (return t))))))
287               
288                                         
289
290)
291
292#+gnu-objc
293(progn
294(defparameter *gnustep-system-root* "/usr/GNUstep/" "The root of all evil.")
295(defparameter *gnustep-libraries-pathname*
296  (merge-pathnames "System/Library/Libraries/" *gnustep-system-root*))
297
298(defloadvar *pending-loaded-classes* ())
299
300(defcallback register-class-callback (:address class :address category :void)
301  (let* ((id (map-objc-class class)))
302    (unless (%null-ptr-p category)
303      (let* ((cell (or (assoc id *pending-loaded-classes*)
304                       (let* ((c (list id)))
305                         (push c *pending-loaded-classes*)
306                         c))))
307        (push (%inc-ptr category 0) (cdr cell))))))
308
309;;; Shouldn't really be GNU-objc-specific.
310
311(defun get-c-format-string (c-format-ptr c-arg-ptr)
312  (do* ((n 128))
313       ()
314    (declare (fixnum n))
315    (%stack-block ((buf n))
316      (let* ((m (#_vsnprintf buf n c-format-ptr c-arg-ptr)))
317        (declare (fixnum m))
318        (cond ((< m 0) (return nil))
319              ((< m n) (return (%get-cstring buf)))
320              (t (setq n m)))))))
321
322
323
324(defun init-gnustep-framework ()
325  (or (getenv "GNUSTEP_SYSTEM_ROOT")
326      (setenv "GNUSTEP_SYSTEM_ROOT" *gnustep-system-root*))
327  (open-shared-library "libobjc.so.1")
328  (setf (%get-ptr (foreign-symbol-address "_objc_load_callback"))
329        register-class-callback)
330  (open-shared-library (namestring (merge-pathnames "libgnustep-base.so"
331                                                    *gnustep-libraries-pathname*)))
332  (open-shared-library (namestring (merge-pathnames "libgnustep-gui.so"
333                                                    *gnustep-libraries-pathname*))))
334
335(def-ccl-pointers gnustep-framework ()
336  (init-gnustep-framework))
337)
338
339(defun get-appkit-version ()
340  (%get-double-float (foreign-symbol-address #+apple-objc "_NSAppKitVersionNumber" #+gnu-objc "NSAppKitVersionNumber")))
341
342(defun get-foundation-version ()
343  (%get-double-float (foreign-symbol-address #+apple-objc "_NSFoundationVersionNumber" #+gnu-objc "NSFoundationVersionNumber")))
344
345(defparameter *appkit-library-version-number* (get-appkit-version))
346(defparameter *foundation-library-version-number* (get-foundation-version))
347
348(def-ccl-pointers cfstring-sections ()
349  (reset-cfstring-sections)
350  (find-cfstring-sections))
351
352;;; When starting up an image that's had ObjC classes in it, all of
353;;; those canonical classes (and metaclasses) will have had their type
354;;; changed (by SAVE-APPLICATION) to, CCL::DEAD-MACPTR and the addresses
355;;; of those classes may be bogus.  The splay trees (objc-class/metaclass-map)
356;;; should be empty.
357;;; For each class that -had- had an assigned ID, determine its ObjC
358;;; class name, and ask ObjC where (if anywhere) the class is now.
359;;; If we get a non-null answer, revive the class pointer and set its
360;;; address appropriately, then add an entry to the splay tree; this
361;;; means that classes that existed on both sides of SAVE-APPLICATION
362;;; will retain the same ID.
363
364(defun revive-objc-classes ()
365  ;; Make a first pass over the class and metaclass tables;
366  ;; resolving those foreign classes that existed in the old
367  ;; image and still exist in the new.
368  (unless (= *foundation-library-version-number* (get-foundation-version))
369    (format *error-output* "~&Foundation version mismatch: expected ~s, got ~s~&"
370            *Foundation-library-version-number* (get-foundation-version))
371    (#_exit 1))
372  (unless (= *appkit-library-version-number* (get-appkit-version))
373    (format *error-output* "~&AppKit version mismatch: expected ~s, got ~s~&"
374            *appkit-library-version-number* (get-appkit-version))
375    (#_exit 1))
376  (let* ((class-map (objc-class-map))
377         (metaclass-map (objc-metaclass-map))
378         (nclasses (%objc-class-count)))
379    (dotimes (i nclasses)
380      (let* ((c (id->objc-class i))
381             (meta-id (objc-class-id->objc-metaclass-id i))
382             (m (id->objc-metaclass meta-id)))
383        (%revive-macptr c)
384        (%revive-macptr m)
385        (unless (splay-tree-get class-map c)
386          (%set-pointer-to-objc-class-address (objc-class-id-foreign-name i) c)
387          ;; If the class is valid and the metaclass is still a
388          ;; dead pointer, revive the metaclass
389          (unless (%null-ptr-p c)
390            (splay-tree-put class-map c i)
391            (unless (splay-tree-get metaclass-map m)
392              (when (%null-ptr-p m)
393                (%setf-macptr m (pref c #+apple-objc :objc_class.isa
394                                      #+gnu-objc :objc_class.class_pointer)))
395              (splay-tree-put metaclass-map m meta-id))))))
396    ;; Second pass: install class objects for user-defined classes,
397    ;; assuming the superclasses are already "revived".  If the
398    ;; superclass is itself user-defined, it'll appear first in the
399    ;; class table; that's an artifact of the current implementation.
400    (dotimes (i nclasses)
401      (let* ((c (id->objc-class i)))
402        (when (and (%null-ptr-p c)
403                   (not (slot-value c 'foreign)))
404          (let* ((super (dolist (s (class-direct-superclasses c)
405                                 (error "No ObjC superclass of ~s" c))
406                          (when (objc-class-p s) (return s))))
407                 (meta-id (objc-class-id->objc-metaclass-id i))
408                 (m (id->objc-metaclass meta-id)))
409            (unless (splay-tree-get metaclass-map m)
410              (%revive-macptr m)
411              (%setf-macptr m (%make-basic-meta-class
412                               (make-cstring (objc-metaclass-id-foreign-name meta-id))
413                               super
414                               (find-class 'ns::ns-object)))
415              (splay-tree-put metaclass-map m meta-id))
416            (%setf-macptr c (%make-class-object
417                             m
418                             super
419                             (make-cstring (objc-class-id-foreign-name i))
420                             (%null-ptr)
421                             0))
422            (multiple-value-bind (ivars instance-size)
423                (%make-objc-ivars c)
424              (%add-objc-class c ivars instance-size)
425              (splay-tree-put class-map c i))))))))
426
427(pushnew #'revive-objc-classes *lisp-system-pointer-functions*
428         :test #'eq
429         :key #'function-name)
430   
431   
432
433(defun install-foreign-objc-class (class)
434  (let* ((id (objc-class-id class)))
435    (unless id
436      (setq id (register-objc-class class)
437            class (id->objc-class id))
438      ;; If not mapped, map the superclass (if there is one.)
439      (let* ((super (pref class :objc_class.super_class)))
440        (unless (%null-ptr-p super)
441          (install-foreign-objc-class super))
442        (let* ((class-foreign-name (%get-cstring
443                                         (pref class :objc_class.name)))
444               (class-name 
445                (objc-to-lisp-classname class-foreign-name
446                                        "NS"))
447               (meta-id (objc-class-id->objc-metaclass-id id)) 
448               (meta (id->objc-metaclass meta-id)))
449          ;; Metaclass may already be initialized.  It'll have a class
450          ;; wrapper if so.
451          (unless (id->objc-metaclass-wrapper meta-id)
452            (let* ((meta-foreign-name (%get-cstring
453                                       (pref meta :objc_class.name)))
454                   (meta-name (intern
455                               (concatenate 'string
456                                            "+"
457                                            (string
458                                             (objc-to-lisp-classname
459                                              meta-foreign-name
460                                              "NS")))
461                                      "NS"))
462                   (meta-super (pref meta :objc_class.super_class)))
463              ;; It's important (here and when initializing the class
464              ;; below) to use the "canonical" (registered) version
465              ;; of the class, since some things in CLOS assume
466              ;; EQness.  We probably don't want to violate that
467              ;; assumption; it'll be easier to revive a saved image
468              ;; if we don't have a lot of EQL-but-not-EQ class pointers
469              ;; to deal with.
470              (initialize-instance meta
471                                   :name meta-name
472                                   :direct-superclasses
473                                   (list
474                                    (if (or (%null-ptr-p meta-super)
475                                            (not (%objc-metaclass-p meta-super)))
476                                      (find-class 'objc:objc-class)
477                                      (canonicalize-registered-metaclass meta-super)))
478                                   :peer class
479                                   :foreign t)
480              (setf (objc-metaclass-id-foreign-name meta-id)
481                    meta-foreign-name)
482              (setf (find-class meta-name) meta)))
483          (setf (slot-value class 'direct-slots)
484                (%compute-foreign-direct-slots class))
485          (initialize-instance class
486                               :name class-name
487                               :direct-superclasses
488                               (list
489                                (if (%null-ptr-p super)
490                                  (find-class 'objc:objc-object)
491                                  (canonicalize-registered-class super)))
492                               :peer meta
493                               :foreign t)
494          (setf (objc-class-id-foreign-name id) class-foreign-name)
495          (setf (find-class class-name) class))))))
496                               
497
498;;; An instance of NSConstantString (which is a subclass of NSString)
499;;; consists of a pointer to the NSConstantString class (which the
500;;; global "_NSConstantStringClassReference" conveniently refers to), a
501;;; pointer to an array of 8-bit characters (doesn't have to be #\Nul
502;;; terminated, but doesn't hurt) and the length of that string (not
503;;; counting any #\Nul.)
504;;; The global reference to the "NSConstantString" class allows us to
505;;; make instances of NSConstantString, ala the @"foo" construct in
506;;; ObjC.  Sure it's ugly, but it seems to be exactly what the ObjC
507;;; compiler does.
508
509
510(defloadvar *NSConstantString-class*
511   #+apple-objc
512  (foreign-symbol-address "__NSConstantStringClassReference")
513  #+gnu-objc
514  (with-cstrs ((name "NSConstantString"))
515      (#_objc_lookup_class name)))
516
517;;; Execute the body with the variable NSSTR bound to a
518;;; stack-allocated NSConstantString instance (made from
519;;; *NSConstantString-class*, CSTRING and LEN).
520(defmacro with-nsstr ((nsstr cstring len) &body body)
521  #+apple-objc
522  `(rlet ((,nsstr :<NSC>onstant<S>tring
523           :isa *NSConstantString-class*
524           :bytes ,cstring
525           :num<B>ytes ,len))
526      ,@body)
527  #+gnu-objc
528  `(rlet ((,nsstr :<NXC>onstant<S>tring
529           :isa *NSConstantString-class*
530           :c_string ,cstring
531           :len ,len))
532    ,@body))
533
534;;; Make a persistent (heap-allocated) NSConstantString.
535
536(defun %make-nsstring (string)
537  "Make a persistent (heap-allocated) NSConstantString from the
538argument lisp string."
539  #+apple-objc
540  (make-record :<NSC>onstant<S>tring
541               :isa *NSConstantString-Class*
542               :bytes (make-cstring string)
543               :num<B>ytes (length string))
544  #+gnu-objc
545  (make-record :<NXC>onstant<S>tring
546               :isa *NSConstantString-Class*
547               :c_string (make-cstring string)
548               :len (length string))
549  )
550
551
552;;; Intern NSConstantString instances.
553(defvar *objc-constant-strings* (make-hash-table :test #'equal))
554
555(defstruct objc-constant-string
556  string
557  nsstringptr)
558
559(defun ns-constant-string (string)
560  (or (gethash string *objc-constant-strings*)
561      (setf (gethash string *objc-constant-strings*)
562            (make-objc-constant-string :string string
563                                       :nsstringptr (%make-nsstring string)))))
564
565(def-ccl-pointers objc-strings ()
566  (maphash #'(lambda (string cached)
567               (setf (objc-constant-string-nsstringptr cached)
568                     (%make-nsstring string)))
569           *objc-constant-strings*))
570
571(defmethod make-load-form ((s objc-constant-string) &optional env)
572  (declare (ignore env))
573  `(ns-constant-string ,(objc-constant-string-string s)))
574
575(defmacro @ (string)
576  `(objc-constant-string-nsstringptr ,(ns-constant-string string)))
577
578#+gnu-objc
579(progn
580  (defcallback lisp-objc-error-handler (:id receiver :int errcode (:* :char) format :address argptr :<BOOL>)
581    (let* ((message (get-c-format-string format argptr)))
582      (error "ObjC runtime error ~d, receiver ~s :~& ~a"
583             errcode receiver message))
584    #$YES)
585
586  (def-ccl-pointers install-lisp-objc-error-handler ()
587    (#_objc_set_error_handler lisp-objc-error-handler)))
588
589
590
591
592
593;;; Registering named objc classes.
594
595
596(defun objc-class-name-string (name)
597  (etypecase name
598    (symbol (lisp-to-objc-classname name))
599    (string name)))
600
601;;; We'd presumably cache this result somewhere, so we'd only do the
602;;; lookup once per session (in general.)
603(defun lookup-objc-class (name &optional error-p)
604  (with-cstrs ((cstr (objc-class-name-string name)))
605    (let* ((p (#+apple-objc #_objc_lookUpClass
606               #+gnu-objc #_objc_lookup_class
607               cstr)))
608      (if (%null-ptr-p p)
609        (if error-p
610          (error "ObjC class ~a not found" name))
611        p))))
612
613(defun %set-pointer-to-objc-class-address (class-name-string ptr)
614  (with-cstrs ((cstr class-name-string))
615    (%setf-macptr ptr
616                  (#+apple-objc #_objc_lookUpClass
617                   #+gnu-objc #_objc_lookup_class
618                   cstr)))
619  nil)
620   
621                 
622
623(defvar *objc-class-descriptors* (make-hash-table :test #'equal))
624
625
626(defstruct objc-class-descriptor
627  name
628  classptr)
629
630(def-ccl-pointers invalidate-objc-class-descriptors ()
631  (maphash #'(lambda (name descriptor)
632               (declare (ignore name))
633               (setf (objc-class-descriptor-classptr descriptor) nil))
634           *objc-class-descriptors*))
635
636(defun %objc-class-classptr (class-descriptor &optional (error-p t))
637  (or (objc-class-descriptor-classptr class-descriptor)
638      (setf (objc-class-descriptor-classptr class-descriptor)
639            (lookup-objc-class (objc-class-descriptor-name class-descriptor)
640                               error-p))))
641
642(defun load-objc-class-descriptor (name)
643  (let* ((descriptor (or (gethash name *objc-class-descriptors*)
644                         (setf (gethash name *objc-class-descriptors*)
645                               (make-objc-class-descriptor  :name name)))))
646    (%objc-class-classptr descriptor nil)
647    descriptor))
648
649(defmacro objc-class-descriptor (name)
650  `(load-objc-class-descriptor ,name))
651
652(defmethod make-load-form ((o objc-class-descriptor) &optional env)
653  (declare (ignore env))
654  `(load-objc-class-descriptor ,(objc-class-descriptor-name o)))
655
656(defmacro @class (name)
657  (let* ((name (objc-class-name-string name)))
658    `(the (@metaclass ,name) (%objc-class-classptr ,(objc-class-descriptor name)))))
659
660;;; This isn't quite the inverse operation of LOOKUP-OBJC-CLASS: it
661;;; returns a simple C string.  and can be applied to a class or any
662;;; instance (returning the class name.)
663(defun objc-class-name (object)
664  #+apple-objc
665  (with-macptrs (p)
666    (%setf-macptr p (#_object_getClassName object))
667    (unless (%null-ptr-p p)
668      (%get-cstring p)))
669  #+gnu-objc
670  (unless (%null-ptr-p object)
671    (with-macptrs ((parent (pref object :objc_object.class_pointer)))
672      (unless (%null-ptr-p parent)
673        (if (logtest (pref parent :objc_class.info) #$_CLS_CLASS)
674          (%get-cstring (pref parent :objc_class.name))
675          (%get-cstring (pref object :objc_class.name)))))))
676
677
678;;; Likewise, we want to cache the selectors ("SEL"s) which identify
679;;; method names.  They can vary from session to session, but within
680;;; a session, all methods with a given name (e.g, "init") will be
681;;; represented by the same SEL.
682(defun get-selector-for (method-name &optional error)
683  (with-cstrs ((cmethod-name method-name))
684    (let* ((p (#+apple-objc #_sel_getUid
685               #+gnu-objc #_sel_get_uid
686               cmethod-name)))
687      (if (%null-ptr-p p)
688        (if error
689          (error "Can't find ObjC selector for ~a" method-name))
690        p))))
691
692(defvar *objc-selectors* (make-hash-table :test #'equal))
693
694(defstruct objc-selector
695  name
696  %sel)
697
698(defun %get-SELECTOR (selector &optional (error-p t))
699  (or (objc-selector-%sel selector)
700      (setf (objc-selector-%sel selector)
701            (get-selector-for (objc-selector-name selector) error-p))))
702
703(def-ccl-pointers objc-selectors ()
704  (maphash #'(lambda (name sel)
705               (declare (ignore name))
706               (setf (objc-selector-%sel sel) nil))
707           *objc-selectors*))
708
709(defun load-objc-selector (name)
710  (let* ((selector (or (gethash name *objc-selectors*)
711                       (setf (gethash name *objc-selectors*)
712                             (make-objc-selector :name name)))))
713    (%get-SELECTOR selector nil)
714    selector))
715
716(defmacro @SELECTOR (name)
717  `(%get-selector ,(load-objc-selector name)))
718
719(defmethod make-load-form ((s objc-selector) &optional env)
720  (declare (ignore env))
721  `(load-objc-selector ,(objc-selector-name s)))
722
723;;; Add a faster way to get the message from a SEL by taking advantage of the
724;;; fact that a selector is really just a canonicalized, interned C string
725;;; containing the message.  (This is an admitted modularity violation;
726;;; there's a more portable but slower way to do this if we ever need to.)
727
728(defun lisp-string-from-sel (sel)
729  (%get-cstring
730   #+apple-objc sel
731   #+gnu-objc (#_sel_get_name sel)))
732
733;;; #_objc_msgSend takes two required arguments (the receiving object
734;;; and the method selector) and 0 or more additional arguments;
735;;; there'd have to be some macrology to handle common cases, since we
736;;; want the compiler to see all of the args in a foreign call.
737
738;;; I don't remmber what the second half of the above comment might
739;;; have been talking about.
740
741(defmacro objc-message-send (receiver selector-name &rest argspecs)
742  (when (evenp (length argspecs))
743    (setq argspecs (append argspecs '(:id))))
744  #+apple-objc
745  `(external-call "_objc_msgSend"
746    :id ,receiver
747    :<SEL> (@selector ,selector-name)
748    ,@argspecs)
749  #+gnu-objc
750    (let* ((r (gensym))
751         (s (gensym))
752         (imp (gensym)))
753    `(with-macptrs ((,r ,receiver)
754                    (,s (@selector ,selector-name))
755                    (,imp (external-call "objc_msg_lookup"
756                                        :id ,r
757                                        :<SEL> ,s
758                                        :<IMP>)))
759      (ff-call ,imp :id ,r :<SEL> ,s ,@argspecs))))
760
761;;; A method that returns a structure (whose size is > 4 bytes on
762;;; darwin, in all cases on linuxppc) does so by copying the structure
763;;; into a pointer passed as its first argument; that means that we
764;;; have to invoke the method via #_objc_msgSend_stret in the #+apple-objc
765;;; case.
766
767(defmacro objc-message-send-stret (structptr receiver selector-name &rest argspecs)
768  (if (evenp (length argspecs))
769    (setq argspecs (append argspecs '(:void)))
770    (unless (member (car (last argspecs)) '(:void nil))
771      (error "Invalid result spec for structure return: ~s"
772             (car (last argspecs)))))
773  #+apple-objc
774  `(external-call "_objc_msgSend_stret"
775    :address ,structptr
776    :id ,receiver
777    :<SEL> (@selector ,selector-name)
778    ,@argspecs)
779    #+gnu-objc
780    (let* ((r (gensym))
781         (s (gensym))
782         (imp (gensym)))
783    `(with-macptrs ((,r ,receiver)
784                    (,s (@selector ,selector-name))
785                    (,imp (external-call "objc_msg_lookup"
786                                         :id ,r
787                                         :<SEL> ,s
788                                         :<IMP>)))
789      (ff-call ,imp :address ,structptr :id ,r :<SEL> ,s ,@argspecs))))
790
791;;; #_objc_msgSendSuper is similar to #_objc_msgSend; its first argument
792;;; is a pointer to a structure of type objc_super {self,  the defining
793;;; class's superclass}.  It only makes sense to use this inside an
794;;; objc method.
795(defmacro objc-message-send-super (super selector-name &rest argspecs)
796  (when (evenp (length argspecs))
797    (setq argspecs (append argspecs '(:id))))
798  #+apple-objc
799  `(external-call "_objc_msgSendSuper"
800    :address ,super
801    :<SEL> (@selector ,selector-name)
802    ,@argspecs)
803  #+gnu-objc
804  (let* ((sup (gensym))
805         (sel (gensym))
806         (imp (gensym)))
807    `(with-macptrs ((,sup ,super)
808                    (,sel (@selector ,selector-name))
809                    (,imp (external-call "objc_msg_lookup_super"
810                                         :<S>uper_t ,sup
811                                         :<SEL> ,sel
812                                         :<IMP>)))
813      (ff-call ,imp
814       :id (pref ,sup :<S>uper.self)
815       :<SEL> ,sel
816       ,@argspecs))))
817
818;;; Send to superclass method, returning a structure.
819(defmacro objc-message-send-super-stret
820    (structptr super selector-name &rest argspecs)
821  (if (evenp (length argspecs))
822    (setq argspecs (append argspecs '(:void)))
823    (unless (member (car (last argspecs)) '(:void nil))
824      (error "Invalid result spec for structure return: ~s"
825             (car (last argspecs)))))
826  #+apple-objc
827  `(external-call "_objc_msgSendSuper_stret"
828    :address ,structptr
829    :address ,super
830    :<SEL> (@selector ,selector-name)
831    ,@argspecs)
832  #+gnu-objc
833  (let* ((sup (gensym))
834         (sel (gensym))
835         (imp (gensym)))
836    `(with-macptrs ((,sup ,super)
837                    (,sel (@selector ,selector-name))
838                    (,imp (external-call "objc_msg_lookup_super"
839                                         :<S>uper_t ,sup
840                                         :<SEL> ,sel
841                                         :<IMP>)))
842      (ff-call ,imp
843       :address ,structptr
844       :id (pref ,sup :<S>uper.self)
845       :<SEL> ,sel
846       ,@argspecs))))
847
848
849
850;;; The first 8 words of non-fp arguments get passed in R3-R10
851(defvar *objc-gpr-offsets*
852  #(4 8 12 16 20 24 28 32))
853
854;;; The first 13 fp arguments get passed in F1-F13 (and also "consume"
855;;; a GPR or two.)  It's certainly possible for an FP arg and a non-
856;;; FP arg to share the same "offset", and parameter offsets aren't
857;;; strictly increasing.
858(defvar *objc-fpr-offsets*
859  #(36 44 52 60 68 76 84 92 100 108 116 124 132))
860
861;;; Just to make things even more confusing: once we've filled in the
862;;; first 8 words of the parameter area, args that aren't passed in
863;;; FP-regs get assigned offsets starting at 32.  That almost makes
864;;; sense (even though it conflicts with the last offset in
865;;; *objc-gpr-offsets* (assigned to R10), but we then have to add
866;;; this constant to the memory offset.
867(defconstant objc-forwarding-stack-offset 8)
868
869(defvar *objc-id-type* (parse-foreign-type :id))
870(defvar *objc-sel-type* (parse-foreign-type :<SEL>))
871(defvar *objc-char-type* (parse-foreign-type :char))
872
873(defun encode-objc-type (type &optional for-ivar)
874  (if (or (eq type *objc-id-type*)
875          (foreign-type-= type *objc-id-type*))
876    "@"
877    (if (or (eq type *objc-sel-type*)
878            (foreign-type-= type *objc-sel-type*))
879      ":"
880      (if (eq (foreign-type-class type) 'root)
881        "v"
882        (typecase type
883          (foreign-pointer-type
884           (let* ((target (foreign-pointer-type-to type)))
885             (if (or (eq target *objc-char-type*)
886                     (foreign-type-= target *objc-char-type*))
887               "*"
888               (format nil "^~a" (encode-objc-type target)))))
889          (foreign-double-float-type "d")
890          (foreign-single-float-type "f")
891          (foreign-integer-type
892           (let* ((signed (foreign-integer-type-signed type))
893                  (bits (foreign-integer-type-bits type)))
894             (if (eq (foreign-integer-type-alignment type) 1)
895               (format nil "b~d" bits)
896               (cond ((= bits 8)
897                      (if signed "c" "C"))
898                     ((= bits 16)
899                      (if signed "s" "S"))
900                     ((= bits 32)
901                      ;; Should be some way of noting "longness".
902                      (if signed "i" "I"))
903                     ((= bits 64)
904                      (if signed "q" "Q"))))))
905          (foreign-record-type
906           (ensure-foreign-type-bits type)
907           (let* ((name (unescape-foreign-name
908                         (or (foreign-record-type-name type) "?")))
909                  (kind (foreign-record-type-kind type))
910                  (fields (foreign-record-type-fields type)))
911             (with-output-to-string (s)
912                                    (format s "~c~a=" (if (eq kind :struct) #\{ #\() name)
913                                    (dolist (f fields (format s "~a" (if (eq kind :struct) #\} #\))))
914                                      (when for-ivar
915                                        (format s "\"~a\""
916                                                (unescape-foreign-name
917                                                 (or (foreign-record-field-name f) "")))
918                                        (format s "~a" (encode-objc-type
919                                                        (foreign-record-field-type f))))))))
920          (foreign-array-type
921           (ensure-foreign-type-bits type)
922           (let* ((dims (foreign-array-type-dimensions type))
923                  (element-type (foreign-array-type-element-type type)))
924             (if dims (format nil "[~d~a]"
925                              (car dims)
926                              (encode-objc-type element-type))
927               (if (or (eq element-type *objc-char-type*)
928                       (foreign-type-= element-type *objc-char-type*))
929                 "*"
930                 (format nil "^~a" (encode-objc-type element-type))))))
931          (t (break "type = ~s" type)))))))
932                 
933(defun encode-objc-method-arglist (arglist result-spec)
934  (let* ((gprs-used 0)
935         (fprs-used 0)
936         (arg-info
937          (flet ((current-memory-arg-offset ()
938                   (+ 32 (* 4 (- gprs-used 8))
939                      objc-forwarding-stack-offset)))
940            (flet ((current-gpr-arg-offset ()
941                     (if (< gprs-used 8)
942                       (svref *objc-gpr-offsets* gprs-used)
943                       (current-memory-arg-offset)))
944                   (current-fpr-arg-offset ()
945                     (if (< fprs-used 13)
946                       (svref *objc-fpr-offsets* fprs-used)
947                       (current-memory-arg-offset))))
948              (let* ((result nil))
949                (dolist (argspec arglist (nreverse result))
950                  (let* ((arg (parse-foreign-type argspec))
951                         (offset 0)
952                         (size 0))
953                    (typecase arg
954                      (foreign-double-float-type
955                       (setq size 8 offset (current-fpr-arg-offset))
956                       (incf fprs-used)
957                       (incf gprs-used 2))
958                      (foreign-single-float-type
959                       (setq size 4 offset (current-fpr-arg-offset))
960                       (incf fprs-used)
961                       (incf gprs-used 1))
962                      (foreign-pointer-type
963                       (setq size 4 offset (current-gpr-arg-offset))
964                       (incf gprs-used))
965                      (foreign-integer-type
966                       (let* ((bits (foreign-type-bits arg)))
967                         (setq size (ceiling bits 8)
968                               offset (current-gpr-arg-offset))
969                         (incf gprs-used (ceiling bits 32))))
970                      ((or foreign-record-type foreign-array-type)
971                       (let* ((bits (ensure-foreign-type-bits arg)))
972                         (setq size (ceiling bits 8)
973                               offset (current-gpr-arg-offset))
974                         (incf gprs-used (ceiling bits 32))))
975                      (t (break "argspec = ~s, arg = ~s" argspec arg)))
976                    (push (list (encode-objc-type arg) offset size) result))))))))
977    (declare (fixnum gprs-used fprs-used))
978    (let* ((max-parm-end
979            (- (apply #'max (mapcar #'(lambda (i) (+ (cadr i) (caddr i)))
980                                    arg-info))
981               objc-forwarding-stack-offset)))
982      (format nil "~a~d~:{~a~d~}"
983              (encode-objc-type
984               (parse-foreign-type result-spec))
985              max-parm-end
986              arg-info))))
987
988;;; In Apple Objc, a class's methods are stored in a (-1)-terminated
989;;; vector of method lists.  In GNU ObjC, method lists are linked
990;;; together.
991(defun %make-method-vector ()
992  #+apple-objc
993  (let* ((method-vector (malloc 16)))
994    (setf (%get-signed-long method-vector 0) 0
995          (%get-signed-long method-vector 4) 0
996          (%get-signed-long method-vector 8) 0
997          (%get-signed-long method-vector 12) -1)
998    method-vector))
999 
1000
1001;;; Make a meta-class object (with no instance variables or class
1002;;; methods.)
1003(defun %make-basic-meta-class (nameptr superptr rootptr)
1004  #+apple-objc
1005  (let* ((method-vector (%make-method-vector)))
1006    (make-record :objc_class
1007                 :isa (pref rootptr :objc_class.isa)
1008                 :super_class (pref superptr :objc_class.isa)
1009                 :name nameptr
1010                 :version 0
1011                 :info #$CLS_META
1012                 :instance_size 0
1013                 :ivars (%null-ptr)
1014                 :method<L>ists method-vector
1015                 :cache (%null-ptr)
1016                 :protocols (%null-ptr)))
1017  #+gnu-objc
1018  (make-record :objc_class
1019               :class_pointer (pref rootptr :objc_class.class_pointer)
1020               :super_class (pref superptr :objc_class.class_pointer)
1021               :name nameptr
1022               :version 0
1023               :info #$_CLS_META
1024               :instance_size 0
1025               :ivars (%null-ptr)
1026               :methods (%null-ptr)
1027               :dtable (%null-ptr)
1028               :subclass_list (%null-ptr)
1029               :sibling_class (%null-ptr)
1030               :protocols (%null-ptr)
1031               :gc_object_type (%null-ptr)))
1032
1033(defun %make-class-object (metaptr superptr nameptr ivars instance-size)
1034  #+apple-objc
1035  (let* ((method-vector (%make-method-vector)))
1036    (make-record :objc_class
1037                 :isa metaptr
1038                 :super_class superptr
1039                 :name nameptr
1040                 :version 0
1041                 :info #$CLS_CLASS
1042                 :instance_size instance-size
1043                 :ivars ivars
1044                 :method<L>ists method-vector
1045                 :cache (%null-ptr)
1046                 :protocols (%null-ptr)))
1047  #+gnu-objc
1048  (make-record :objc_class
1049                 :class_pointer metaptr
1050                 :super_class superptr
1051                 :name nameptr
1052                 :version 0
1053                 :info #$_CLS_CLASS
1054                 :instance_size instance-size
1055                 :ivars ivars
1056                 :methods (%null-ptr)
1057                 :dtable (%null-ptr)
1058                 :protocols (%null-ptr)))
1059
1060(defun superclass-instance-size (class)
1061  (with-macptrs ((super (pref class :objc_class.super_class)))
1062    (if (%null-ptr-p super)
1063      0
1064      (pref super :objc_class.instance_size))))
1065
1066       
1067
1068
1069#+gnu-objc
1070(progn
1071(defloadvar *gnu-objc-runtime-mutex*
1072    (%get-ptr (foreign-symbol-address "__objc_runtime_mutex")))
1073(defmacro with-gnu-objc-mutex-locked ((mutex) &body body)
1074  (let* ((mname (gensym)))
1075    `(let ((,mname ,mutex))
1076      (unwind-protect
1077           (progn
1078             (external-call "objc_mutex_lock" :address ,mname :void)
1079             ,@body)
1080        (external-call "objc_mutex_lock" :address ,mname :void)))))
1081)
1082
1083(defun %objc-metaclass-p (class)
1084  (logtest (pref class :objc_class.info)
1085           #+apple-objc #$CLS_META
1086           #+gnu-objc #$_CLS_META))
1087           
1088(defun %objc-class-posing-p (class)
1089  (logtest (pref class :objc_class.info)
1090           #+apple-objc #$CLS_POSING
1091           #+gnu-objc #$_CLS_POSING))
1092
1093
1094
1095
1096;;; Create (malloc) class and metaclass objects with the specified
1097;;; name (string) and superclass name.  Initialize the metaclass
1098;;; instance, but don't install the class in the ObjC runtime system
1099;;; (yet): we don't know anything about its ivars and don't know
1100;;; how big instances will be yet.
1101;;; If an ObjC class with this name already exists, we're very
1102;;; confused; check for that case and error out if it occurs.
1103(defun %allocate-objc-class (name superptr)
1104  (let* ((class-name (compute-objc-classname name)))
1105    (if (lookup-objc-class class-name nil)
1106      (error "An Objective C class with name ~s already exists." class-name))
1107    (let* ((nameptr (make-cstring class-name))
1108           (id (register-objc-class
1109                (%make-class-object
1110                 (%make-basic-meta-class nameptr superptr (@class "NSObject"))
1111                 superptr
1112                 nameptr
1113                 (%null-ptr)
1114                 0)))
1115           (meta-id (objc-class-id->objc-metaclass-id id))
1116           (meta (id->objc-metaclass meta-id))
1117           (class (id->objc-class id))
1118           (meta-name (intern (format nil "+~a" name)
1119                              (symbol-package name)))
1120           (meta-super (canonicalize-registered-metaclass
1121                        (pref meta :objc_class.super_class))))
1122      (initialize-instance meta
1123                         :name meta-name
1124                         :direct-superclasses (list meta-super))
1125      (setf (objc-class-id-foreign-name id) class-name
1126            (objc-metaclass-id-foreign-name meta-id) class-name
1127            (find-class meta-name) meta)
1128    class)))
1129
1130;;; Set up the class's ivar_list and instance_size fields, then
1131;;; add the class to the ObjC runtime.
1132(defun %add-objc-class (class ivars instance-size)
1133  (setf
1134   (pref class :objc_class.ivars) ivars
1135   (pref class :objc_class.instance_size) instance-size)
1136  #+apple-objc
1137  (#_objc_addClass class)
1138  #+gnu-objc
1139  ;; Why would anyone want to create a class without creating a Module ?
1140  ;; Rather than ask that vexing question, let's create a Module with
1141  ;; one class in it and use #___objc_exec_class to add the Module.
1142  ;; (I mean "... to add the class", of course.
1143  ;; It appears that we have to heap allocate the module, symtab, and
1144  ;; module name: the GNU ObjC runtime wants to add the module to a list
1145  ;; that it subsequently ignores.
1146  (let* ((name (make-cstring "Phony Module"))
1147         (symtab (malloc (+ (record-length :objc_symtab) (record-length (:* :void)))))
1148         (m (make-record :objc_module
1149                         :version 8 #|OBJC_VERSION|#
1150                         :size (record-length :<M>odule)
1151                         :name name
1152                         :symtab symtab)))
1153    (setf (%get-ptr symtab (record-length :objc_symtab)) (%null-ptr))
1154    (setf (pref symtab :objc_symtab.sel_ref_cnt) 0
1155          (pref symtab :objc_symtab.refs) (%null-ptr)
1156          (pref symtab :objc_symtab.cls_def_cnt) 1
1157          (pref symtab :objc_symtab.cat_def_cnt) 0
1158          (%get-ptr (pref symtab :objc_symtab.defs)) class
1159          (pref class :objc_class.info) (logior #$_CLS_RESOLV (pref class :objc_class.info)))
1160    (#___objc_exec_class m)))
1161
1162
1163
1164;;; Return the "canonical" version of P iff it's a known ObjC class
1165(defun objc-class-p (p)
1166  (if (typep p 'macptr)
1167    (let* ((id (objc-class-id p)))
1168      (if id (id->objc-class id)))))
1169
1170;;; Return the canonical version of P iff it's a known ObjC metaclass
1171(defun objc-metaclass-p (p)
1172  (if (typep p 'macptr)
1173    (let* ((id (objc-metaclass-id p)))
1174      (if id (id->objc-metaclass id)))))
1175
1176;;; If P is an ObjC instance, return a pointer to its class.
1177;;; This assumes that all instances are allocated via something that's
1178;;; ultimately malloc-based.
1179(defun objc-instance-p (p)
1180  (when (typep p 'macptr)
1181    (let* ((idx (%objc-instance-class-index p)))
1182      (if idx (id->objc-class  idx)))))
1183
1184
1185#+apple-objc
1186(defun zone-pointer-size (p)
1187  (with-macptrs ((zone (#_malloc_zone_from_ptr p)))
1188    (unless (%null-ptr-p zone)
1189      (let* ((size (ff-call (pref zone :malloc_zone_t.size)
1190                            :address zone
1191                            :address p
1192                            :int)))
1193        (declare (fixnum size))
1194        (unless (zerop size)
1195          size)))))
1196 
1197(defun %objc-instance-class-index (p)
1198  #+apple-objc
1199  (if (or (pointer-in-cfstring-section-p p)
1200          (with-macptrs ((zone (#_malloc_zone_from_ptr p)))
1201            (not (%null-ptr-p zone))))
1202    (with-macptrs ((parent (pref p :objc_object.isa)))
1203      (objc-class-id parent)))
1204  #+gnu-objc
1205  (with-macptrs ((parent (pref p objc_object.class_pointer)))
1206    (objc-class-id-parent))
1207  )
1208
1209;;; If an instance, return (values :INSTANCE <class>)
1210;;; If a class, return (values :CLASS <class>).
1211;;; If a metaclass, return (values :METACLASS <metaclass>).
1212;;; Else return (values NIL NIL).
1213(defun objc-object-p (p)
1214  (let* ((instance-p (objc-instance-p p)))
1215    (if instance-p
1216      (values :instance instance-p)
1217      (let* ((class-p (objc-class-p p)))
1218        (if class-p
1219          (values :class class-p)
1220          (let* ((metaclass-p (objc-metaclass-p p)))
1221            (if metaclass-p
1222              (values :metaclass metaclass-p)
1223              (values nil nil))))))))
1224
1225       
1226
1227;;; Stub until BRIDGE is loaded
1228(defun update-type-signatures-for-method (m c) (declare (ignore m c)))
1229
1230
1231;;; If the class contains an mlist that contains a method that
1232;;; matches (is EQL to) the selector, remove the mlist and
1233;;; set its IMP; return the containing mlist.
1234;;; If the class doesn't contain any matching mlist, create
1235;;; an mlist with one method slot, initialize the method, and
1236;;; return the new mlist.  Doing it this way ensures
1237;;; that the objc runtime will invalidate any cached references
1238;;; to the old IMP, at least as far as objc method dispatch is
1239;;; concerned.
1240(defun %mlist-containing (classptr selector typestring imp)
1241  #-apple-objc (declare (ignore classptr selector typestring imp))
1242  #+apple-objc
1243  (%stack-block ((iter 4))
1244    (setf (%get-ptr iter) (%null-ptr))
1245    (loop
1246        (let* ((mlist (#_class_nextMethodList classptr iter)))
1247          (when (%null-ptr-p mlist)
1248            (let* ((mlist (make-record :objc_method_list
1249                                       :method_count 1))
1250                   (method (pref mlist :objc_method_list.method_list)))
1251              (setf (pref method :objc_method.method_name) selector
1252                    (pref method :objc_method.method_types)
1253                    (make-cstring typestring)
1254                    (pref method :objc_method.method_imp) imp)
1255              (update-type-signatures-for-method method classptr)
1256              (return mlist)))
1257          (do* ((n (pref mlist :objc_method_list.method_count))
1258                (i 0 (1+ i))
1259                (method (pref mlist :objc_method_list.method_list)
1260                        (%incf-ptr method (record-length :objc_method))))
1261               ((= i n))
1262            (declare (fixnum i n))
1263            (when (eql selector (pref method :objc_method.method_name))
1264              (#_class_removeMethods classptr mlist)
1265              (setf (pref method :objc_method.method_imp) imp)
1266              (return-from %mlist-containing mlist)))))))
1267             
1268
1269(defun %add-objc-method (classptr selector typestring imp)
1270  #+apple-objc
1271  (#_class_addMethods classptr
1272                      (%mlist-containing classptr selector typestring imp))
1273  #+gnu-objc
1274  ;;; We have to do this ourselves, and have to do it with the runtime
1275  ;;; mutex held.
1276  (with-gnu-objc-mutex-locked (*gnu-objc-runtime-mutex*)
1277    (let* ((ctypestring (make-cstring typestring))
1278           (new-mlist nil))
1279      (with-macptrs ((method (external-call "search_for_method_in_list"
1280                              :address (pref classptr :objc_class.methods)
1281                              :address selector
1282                              :address)))
1283        (when (%null-ptr-p method)
1284          (setq new-mlist (make-record :objc_method_list :method_count 1))
1285          (%setf-macptr method (pref new-mlist :objc_method_list.method_list)))
1286        (setf (pref method :objc_method.method_name) selector
1287              (pref method :objc_method.method_types) ctypestring
1288              (pref method :objc_method.method_imp) imp)
1289        (if new-mlist
1290          (external-call "GSObjCAddMethods"
1291                         :address classptr
1292                         :address new-mlist
1293                         :void)
1294          (external-call "__objc_update_dispatch_table_for_class"
1295                         :address classptr
1296                         :void))
1297        (update-type-signatures-for-method (%inc-ptr method 0) classptr)))))
1298
1299(defvar *lisp-objc-methods* (make-hash-table :test #'eq))
1300
1301(defstruct lisp-objc-method
1302  class-descriptor
1303  sel
1304  typestring
1305  class-p                               ;t for class methods
1306  imp                                   ; callback ptr
1307  )
1308
1309(defun %add-lisp-objc-method (m)
1310  (let* ((class (%objc-class-classptr (lisp-objc-method-class-descriptor m)))
1311         (sel (%get-selector (lisp-objc-method-sel m)))
1312         (typestring (lisp-objc-method-typestring m))
1313         (imp (lisp-objc-method-imp m)))
1314    (%add-objc-method
1315     (if (lisp-objc-method-class-p m)
1316       (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer)
1317       class)
1318     sel
1319     typestring
1320     imp)))
1321
1322(def-ccl-pointers add-objc-methods ()
1323  (maphash #'(lambda (impname m)
1324               (declare (ignore impname))
1325               (%add-lisp-objc-method m))
1326           *lisp-objc-methods*))
1327
1328(defun %define-lisp-objc-method (impname classname selname typestring imp
1329                                         &optional class-p)
1330  (%add-lisp-objc-method
1331   (setf (gethash impname *lisp-objc-methods*)
1332         (make-lisp-objc-method
1333          :class-descriptor (load-objc-class-descriptor classname)
1334          :sel (load-objc-selector selname)
1335          :typestring typestring
1336          :imp imp
1337          :class-p class-p)))
1338  impname)
1339   
1340
1341
1342
1343
1344;;; If any of the argspecs denote a value of type :<BOOL>, push an
1345;;; appropriate SETQ on the front of the body.  (Order doesn't matter.)
1346(defun coerce-foreign-boolean-args (argspecs body)
1347  (do* ((argspecs argspecs (cddr argspecs))
1348        (type (car argspecs) (car argspecs))
1349        (var (cadr argspecs) (cadr argspecs)))
1350       ((null argspecs) body)
1351    (when (eq type :<BOOL>)
1352      (push `(setq ,var (not (eql ,var 0))) body))))
1353     
1354(defun lisp-boolean->foreign-boolean (form)
1355  (let* ((val (gensym)))
1356    `((let* ((,val (progn ,@form)))
1357        (if (and ,val (not (eql 0 ,val))) 1 0)))))
1358
1359;;; Return, as multiple values:
1360;;;  the selector name, as a string
1361;;;  the ObjC class name, as a string
1362;;;  the foreign result type
1363;;;  the foreign argument type/argument list
1364;;;  the body
1365;;;  a string which encodes the foreign result and argument types
1366(defun parse-objc-method (selector-arg class-arg body)
1367  (let* ((class-name (objc-class-name-string class-arg))
1368         (selector-form selector-arg)
1369         (selector nil)
1370         (argspecs nil)
1371         (resulttype nil))
1372    (flet ((bad-selector (why) (error "Can't parse method selector ~s : ~a"
1373                                   selector-arg why)))
1374      (typecase selector-form
1375        (string
1376         (let* ((specs (pop body)))
1377             (setq selector selector-form)
1378             (if (evenp (length specs))
1379               (setq argspecs specs resulttype :id)
1380               (setq resulttype (car (last specs))
1381                     argspecs (butlast specs)))))
1382        (cons                           ;sic
1383         (setq resulttype (pop selector-form))
1384         (unless (consp selector-form)
1385           (bad-selector "selector-form not a cons"))
1386         (ccl::collect ((components)
1387                         (specs))
1388           ;; At this point, selector-form should be either a list of
1389           ;; a single symbol (a lispified version of the selector name
1390           ;; of a selector that takes no arguments) or a list of keyword/
1391           ;; variable pairs.  Each keyword is a lispified component of
1392           ;; the selector name; each "variable" is either a symbol
1393           ;; or a list of the form (<foreign-type> <symbol>), where
1394           ;; an atomic variable is shorthand for (:id <symbol>).
1395           (if (and (null (cdr selector-form))
1396                    (car selector-form)
1397                    (typep (car selector-form) 'symbol)
1398                    (not (typep (car selector-form) 'keyword)))
1399             (components (car selector-form))
1400             (progn
1401               (unless (evenp (length selector-form))
1402                 (bad-selector "Odd length"))
1403               (do* ((s selector-form (cddr s))
1404                     (comp (car s) (car s))
1405                     (var (cadr s) (cadr s)))
1406                    ((null s))
1407                 (unless (typep comp 'keyword) (bad-selector "not a keyword"))
1408                 (components comp)
1409                 (cond ((atom var)
1410                        (unless (and var (symbolp var))
1411                          (bad-selector "not a non-null symbol"))
1412                        (specs :id)
1413                        (specs var))
1414                       ((and (consp (cdr var))
1415                             (null (cddr var))
1416                             (cadr var)
1417                             (symbolp (cadr var)))
1418                        (specs (car var))
1419                        (specs (cadr var)))
1420                       (t (bad-selector "bad variable/type clause"))))))
1421           (setq argspecs (specs)
1422                 selector (lisp-to-objc-message (components)))))
1423        (t (bad-selector "general failure")))
1424      ;; If the result type is of the form (:STRUCT <typespec> <name>),
1425      ;; make <name> be the first argument (of type :address) and
1426      ;; make the resulttype :void
1427      (when (and (consp resulttype)
1428                 (eq (car resulttype) :struct))
1429        (destructuring-bind (typespec name) (cdr resulttype)
1430        (if (and (typep name 'symbol)
1431                 (typep (parse-foreign-type typespec)
1432                        'foreign-record-type))
1433          (progn
1434            (push name argspecs)
1435            (push :address argspecs)
1436            (setq resulttype :void))
1437          (bad-selector "Bad struct return type"))))
1438      (values selector
1439              class-name
1440              resulttype
1441              argspecs
1442              body
1443              (do* ((argtypes ())
1444                    (argspecs argspecs (cddr argspecs)))
1445                   ((null argspecs) (encode-objc-method-arglist
1446                                     `(:id :<sel> ,@(nreverse argtypes))
1447                                     resulttype))
1448                (push (car argspecs) argtypes))))))
1449
1450(defun objc-method-definition-form (class-p selector-arg class-arg body env)
1451  (multiple-value-bind (selector-name
1452                        class-name
1453                        resulttype
1454                        argspecs
1455                        body
1456                        typestring)
1457      (parse-objc-method selector-arg class-arg body)
1458      (multiple-value-bind (body decls) (parse-body body env)
1459        (setq body (coerce-foreign-boolean-args argspecs body))
1460        (if (eq resulttype :<BOOL>)
1461          (setq body (lisp-boolean->foreign-boolean body)))
1462        (let* ((impname (intern (format nil "~c[~a ~a]"
1463                                        (if class-p #\+ #\-)
1464                                        class-name
1465                                        selector-name)))
1466               (self (intern "SELF"))
1467               (_cmd (intern "_CMD"))
1468               (super (gensym "SUPER")) 
1469               (params `(:id ,self :<sel> ,_cmd ,@argspecs)))
1470          `(progn
1471            (defcallback ,impname
1472                    (:without-interrupts nil
1473                                         #+(and openmcl-native-threads apple-objc) :error-return
1474                                         #+(and openmcl-native-threads apple-objc)  (condition objc-callback-error-return) ,@params ,resulttype)
1475                  (declare (ignorable ,_cmd))
1476                  ,@decls
1477                  (rlet ((,super :objc_super
1478                           #+apple-objc :receiver #+gnu-objc :self ,self
1479                           :class
1480                           ,@(if class-p
1481                                 `((pref
1482                                    (pref (@class ,class-name)
1483                                     #+apple-objc :objc_class.isa
1484                                     #+gnu-objc :objc_class.super_class )
1485                                    :objc_class.super_class))
1486                                 `((pref (@class ,class-name) :objc_class.super_class)))))
1487                    (macrolet ((send-super (msg &rest args &environment env) 
1488                                 (make-optimized-send nil msg args env nil ',super ,class-name))
1489                               (send-super/stret (s msg &rest args &environment env) 
1490                                 (make-optimized-send nil msg args env s ',super ,class-name)))
1491                      (flet ((%send-super (msg &rest args)
1492                               (make-general-send nil msg args nil ,super ,class-name))
1493                             (%send-super/stret (s msg &rest args)
1494                               (make-general-send nil msg args s ,super ,class-name))
1495                             (super () ,super))
1496                        ,@body))))
1497            (%define-lisp-objc-method
1498             ',impname
1499             ,class-name
1500             ,selector-name
1501             ,typestring
1502             ,impname
1503             ,class-p))))))
1504
1505(defmacro define-objc-method ((selector-arg class-arg)
1506                              &body body &environment env)
1507  (objc-method-definition-form nil selector-arg class-arg body env))
1508
1509(defmacro define-objc-class-method ((selector-arg class-arg)
1510                                     &body body &environment env)
1511  (objc-method-definition-form t selector-arg class-arg body env))
1512
1513(defun class-get-instance-method (class sel)
1514  #+apple-objc (progn
1515                 (unless (logtest #$CLS_INITIALIZED (pref (pref class :objc_class.isa)  :objc_class.info))
1516                   ;; Do this for effect; ignore the :<IMP> it returns.
1517                   ;; (It should cause the CLS_NEED_BIND flag to turn itself
1518                   ;; off after the class has been initialized; we need
1519                   ;; the class and all superclasses to have been initialized,
1520                   ;; so that we can find category methods via
1521                   ;; #_class_getInstanceMethod.
1522                   (external-call "_class_lookupMethod"
1523                                  :id class
1524                                  :<SEL> sel
1525                                  :address))
1526                 (#_class_getInstanceMethod class sel))
1527  #+gnu-objc (#_class_get_instance_method class sel))
1528
1529(defun class-get-class-method (class sel)
1530  #+apple-objc (#_class_getClassMethod class sel)
1531  #+gnu-objc   (#_class_get_class_method class sel))
1532
1533(defun method-get-number-of-arguments (m)
1534  #+apple-objc (#_method_getNumberOfArguments m)
1535  #+gnu-objc (#_method_get_number_of_arguments m))
1536
1537#+apple-objc
1538(progn
1539(defloadvar *original-deallocate-hook*
1540    (%get-ptr (foreign-symbol-address "__dealloc")))
1541
1542(defcallback deallocate-nsobject (:address obj :int)
1543  (unless (%null-ptr-p obj)
1544        (remhash obj *objc-object-slot-vectors*)
1545    (ff-call *original-deallocate-hook* :address obj :int)))
1546
1547(defun install-lisp-deallocate-hook ()
1548  (setf (%get-ptr (foreign-symbol-address "__dealloc")) deallocate-nsobject))
1549
1550(def-ccl-pointers install-deallocate-hook ()
1551  (install-lisp-deallocate-hook))
1552
1553(defun uninstall-lisp-deallocate-hook ()
1554  (clrhash *objc-object-slot-vectors*)
1555  (setf (%get-ptr (foreign-symbol-address "__dealloc")) *original-deallocate-hook*))
1556
1557(pushnew #'uninstall-lisp-deallocate-hook *save-exit-functions* :test #'eq
1558         :key #'function-name)
1559)
1560
1561
1562;;; Return a typestring and offset as multiple values.
1563
1564(defun objc-get-method-argument-info (m i)
1565  #+apple-objc
1566  (%stack-block ((type 4) (offset 4))
1567    (#_method_getArgumentInfo m i type offset)
1568    (values (%get-cstring (%get-ptr type)) (%get-signed-long offset)))
1569  #+gnu-objc
1570  (progn
1571    (with-macptrs ((typespec (#_objc_skip_argspec (pref m :objc_method.method_types))))
1572      (dotimes (j i (values (%get-cstring typespec)
1573                            (#_strtol (#_objc_skip_typespec typespec)
1574                                      (%null-ptr)
1575                                      10.)))
1576        (%setf-macptr typespec (#_objc_skip_argspec typespec))))))
1577
1578 
1579
1580
1581
1582(defloadvar *nsstring-newline* #@"
1583")
1584
1585
1586(defun retain-objc-instance (instance)
1587  (objc-message-send instance "retain"))
1588
1589;;; Execute BODY with an autorelease pool
1590
1591(defun create-autorelease-pool ()
1592  (objc-message-send
1593   (objc-message-send (@class "NSAutoreleasePool") "alloc") "init"))
1594
1595(defun release-autorelease-pool (p)
1596  (objc-message-send p "release"))
1597
1598(defmacro with-autorelease-pool (&body body)
1599  (let ((pool-temp (gensym)))
1600    `(let ((,pool-temp (create-autorelease-pool)))
1601      (unwind-protect
1602           ,@body
1603        (release-autorelease-pool ,pool-temp)))))
1604
1605;;; This can fail if the nsstring contains non-8-bit characters.
1606(defun lisp-string-from-nsstring (nsstring)
1607  (with-macptrs (cstring)
1608    (%setf-macptr cstring (objc-message-send nsstring "cString" (* :char)))
1609    (unless (%null-ptr-p cstring)
1610      (%get-cstring cstring))))
1611
1612(defmacro with-ns-exceptions-as-errors (&body body)
1613  #+apple-objc
1614  (let* ((nshandler (gensym))
1615         (cframe (gensym)))
1616    `(rletZ ((,nshandler :<NSH>andler2))
1617      (unwind-protect
1618           (progn
1619             (external-call "__NSAddHandler2" :address ,nshandler :void)
1620             (catch ,nshandler
1621               (with-c-frame ,cframe
1622                 (%associate-jmp-buf-with-catch-frame
1623                  ,nshandler
1624                  (%fixnum-ref (%current-tcr) ppc32::tcr.catch-top)
1625                  ,cframe)
1626                 (progn
1627                   ,@body))))
1628        (check-ns-exception ,nshandler))))
1629  #+gnu-objc
1630  `(progn ,@body)
1631  )
1632
1633#+apple-objc
1634(defun check-ns-exception (nshandler)
1635  (with-macptrs ((exception (external-call "__NSExceptionObjectFromHandler2"
1636                                           :address nshandler
1637                                           :address)))
1638    (if (%null-ptr-p exception)
1639      (external-call "__NSRemoveHandler2" :address nshandler :void)
1640      (error (ns-exception->lisp-condition (%inc-ptr exception 0))))))
1641
1642
Note: See TracBrowser for help on using the repository browser.