source: trunk/ccl/examples/objc-support.lisp @ 5937

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

Call REGISTER-OBJC-INIT-MESSAGES after MAP-OBJC-CLASSES in
LOAD-OBJC-EXTENSION-FRAMEWORK.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 15.4 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2
3(in-package "CCL")
4
5(eval-when (:compile-toplevel :load-toplevel :execute)
6  (require "BRIDGE"))
7
8(defun allocate-objc-object (class)
9  (send class 'alloc))
10
11
12#-apple-objc-2.0
13(progn
14  (def-foreign-type :<CGF>loat :float)
15  (def-foreign-type :<NSUI>nteger :unsigned)
16  (def-foreign-type :<NSI>nteger :signed)
17  )
18
19(defconstant +cgfloat-zero+
20  #+(and apple-objc-2.0 64-bit-target) 0.0d0
21  #-(and apple-objc-2.0 64-bit-target) 0.0f0)
22
23(deftype cg-float ()
24    #+(and apple-objc-2.0 64-bit-target) 'double-float
25    #-(and apple-objc-2.0 64-bit-target) 'single-float)
26
27#+apple-objc
28(defun iterate-over-objc-classes (fn)
29  (let* ((n (#_objc_getClassList (%null-ptr) 0)))
30    (declare (fixnum n))
31    (%stack-block ((buffer (the fixnum (ash n target::word-shift))))
32      (#_objc_getClassList buffer n)
33      (do* ((i 0 (1+ i)))
34           ((= i n) (values))
35        (declare (fixnum i))
36        (funcall fn (%get-ptr buffer (the fixnum  (ash i target::word-shift))))))))
37
38#+gnu-objc
39(defun iterate-over-objc-classes (fn)
40  (rletZ ((enum-state :address))
41    (loop
42      (let* ((class (#_objc_next_class enum-state)))
43        (if (%null-ptr-p class)
44          (return)
45          (funcall fn class))))))
46
47(defun %note-protocol (p)
48  (with-macptrs ((cname (objc-message-send p "name" :address)))
49    (let* ((namelen (%cstrlen cname))
50           (name (make-string namelen)))
51      (declare (dynamic-extent name))
52      (%str-from-ptr cname namelen name)
53      (unless (gethash name *objc-protocols*)
54        (setf (gethash (subseq name 0) *objc-protocols*)
55              (%inc-ptr p 0))))))
56
57(defun note-class-protocols (class)
58  #-apple-objc-2.0
59  (do* ((protocols (pref class :objc_class.protocols)
60                   (pref protocols :objc_protocol_list.next)))
61       ((%null-ptr-p protocols))
62    (let* ((count (pref protocols :objc_protocol_list.count)))
63      (with-macptrs ((list (pref protocols :objc_protocol_list.list)))
64        (dotimes (i count)
65          (with-macptrs ((p (paref list (:* (:* (:struct :<P>rotocol))) i)))
66            (%note-protocol p))))))
67  #+apple-objc-2.0
68  (rlet ((p-out-count :int))
69    (with-macptrs ((protocols (#_class_copyProtocolList class p-out-count)))
70      (let* ((n (pref p-out-count :int)))
71        (dotimes (i n)
72          (with-macptrs ((p (paref protocols (:* (:* (:struct :<P>rotocol))) i)))
73            (%note-protocol p))))
74      (unless (%null-ptr-p protocols) (#_free protocols)))))
75           
76
77(defun map-objc-classes (&optional (lookup-in-database-p t))
78  (iterate-over-objc-classes
79   #'(lambda (class)
80       (note-class-protocols class)
81       (install-foreign-objc-class class lookup-in-database-p))))
82 
83
84(map-objc-classes)
85(register-objc-init-messages)
86
87#+gnu-objc
88(defun iterate-over-class-methods (class method-function)
89  (do* ((mlist (pref class :objc_class.methods)
90               (pref mlist :objc_method_list.method_next)))
91       ((%null-ptr-p mlist))
92    (do* ((n (pref mlist :objc_method_list.method_count))
93          (i 0 (1+ i))
94          (method (pref mlist :objc_method_list.method_list)
95                  (%incf-ptr method (record-length :objc_method))))
96         ((= i n))
97      (declare (fixnum i n))
98      (funcall method-function method class))))
99
100#+gnu-objc
101(progn
102  ;; Er, um ... this needs lots-o-work.a
103  (let* ((objc-class-count 0))
104    (defun reset-objc-class-count () (setq objc-class-count 0))
105    (defun note-all-library-methods (method-function)
106      (do* ((i objc-class-count (1+ i))
107            (class (id->objc-class i) (id->objc-class i)))
108           ((eq class 0))
109        (iterate-over-class-methods class method-function)
110        (iterate-over-class-methods (id->objc-metaclass i) method-function))))
111  (def-ccl-pointers revive-objc-classes ()
112    (reset-objc-class-count)))
113
114(defun retain-obcj-object (x)
115  (objc-message-send x "retain"))
116
117
118
119(defvar *condition-id-map* (make-id-map) "Map lisp conditions to small integers")
120
121;;; Encapsulate an NSException in a lisp condition.
122(define-condition ns-exception (error)
123  ((ns-exception :initarg :ns-exception :accessor ns-exception))
124  (:report (lambda (c s)
125             (format s "Objective-C runtime exception: ~&~a"
126                     (nsobject-description (ns-exception c))))))
127
128
129
130(defclass ns-lisp-exception (ns::ns-exception)
131    ((condition :initarg :condition :initform nil :reader ns-lisp-exception-condition))
132  (:metaclass ns::+ns-object))
133
134(define-objc-method ((:id init)
135                     ns-lisp-exception)
136  (send self
137        :init-with-name #@"lisp exception"
138        :reason #@"lisp exception"
139        :user-info (%null-ptr)))
140
141
142(define-objc-method ((:id reason) ns-lisp-exception)
143  (with-slots (condition) self
144    (if condition
145      (%make-nsstring (format nil "~A" condition))
146      (send-super 'reason))))
147   
148(define-objc-method ((:id description) ns-lisp-exception)
149  (send (find-class 'ns:ns-string)
150        :string-with-format #@"Lisp exception: %@"
151        (:id (send self 'reason))))
152
153
154       
155             
156                     
157(defun ns-exception->lisp-condition (nsexception)
158  (if (typep nsexception 'ns-lisp-exception)
159    (ns-lisp-exception-condition nsexception)
160    (make-condition 'ns-exception :ns-exception nsexception)))
161
162
163(defmethod ns-exception ((c condition))
164  "Map a lisp condition object to an NSException.  Note that instances
165of the NS-EXCEPTION condition class implement this by accessing an
166instance variable."
167  ;;; Create an NSLispException with a lispid that encapsulates
168  ;;; this condition.
169  ;;;
170
171
172  #|(dbg (format nil "~a" c))|#
173  ;;(#_NSLog #@"Lisp exception: %@" :id (%make-nsstring (format nil "~a" c)))
174  (make-instance 'ns-lisp-exception :condition c))
175 
176
177
178
179
180#+apple-objc
181(progn
182;;; (#__NSRaiseError nsexception) is entirely equivalent to
183;;; -[NSException raise].  If we get nervous about passing the former
184;;; around, we can always look up the method imp of the latter.
185(defmacro raising-ns-exception-on-error (&body body)
186  `(handler-case (progn ,@body)
187    (error (c) (external-call "__NSRaiseError" :address (ns-exception c) :void))))
188
189#+ppc-target
190(defun objc-callback-error-return (condition return-value-pointer return-address-pointer)
191  ;; On PPC, the "address" of an external entry point is always
192  ;; aligned on a 32-bit word boundary.  On PPC32, it can always
193  ;; be represented as a fixnum; on PPC64, it might be a pointer
194  ;; instead.
195  ;; Note that this clobbers the actual (foreign) return address,
196  ;; replacing it with the address of #__NSRaiseError.  Note also
197  ;; that storing the NSException object as the return value has
198  ;; the desired effect of causing #__NSRaiseError to be called
199  ;; with that NSException as its argument (because r3 is used both
200  ;; as the canonical return value register and used to pass the
201  ;; first argument on PPC.)
202  (let* ((addr (%reference-external-entry-point (load-time-value (external "__NSRaiseError")))))
203    (if (typep addr 'fixnum)
204      (%set-object return-address-pointer 0 addr)
205      (setf (%get-ptr return-address-pointer 0) addr)))
206  (setf (%get-ptr return-value-pointer 0) (ns-exception condition))
207  nil)
208
209#+x8664-target
210(progn
211(defloadvar *x8664-objc-callback-error-return-trampoline*
212    (let* ((code-bytes '(#x48 #x89 #xc7      ; movq %rax %rdi
213                         #x66 #x48 #x0f #x7e #xc0 ; movd %xmm0,%rax
214                         #x52                ; pushq %rdx
215                         #xff #xe0))         ; jmp *rax
216           (nbytes (length code-bytes))
217           (ptr (#_malloc nbytes)))
218      (dotimes (i nbytes ptr)
219        (setf (%get-unsigned-byte ptr i) (pop code-bytes)))))
220
221(defun objc-callback-error-return (condition return-value-pointer return-address-pointer) 
222  ;; The callback glue reserves space for %rax at return-value-pointer-8,
223  ;; for %rdx at -16, for %xmm0 at -24.  Store NS-EXCEPTION in the
224  ;; %rax slot, the address of #__NSRaiseError in the %rdx slot, the
225  ;; original return address in the %xmm0 slot, and force a return to
226  ;; the trampoline code above.
227  (setf (%get-ptr return-value-pointer -8) (ns-exception condition)
228        (%get-ptr return-value-pointer -16) (%get-ptr return-address-pointer 0)
229        (%get-ptr return-address-pointer 0) *x8664-objc-callback-error-return-trampoline*)
230  ;; A foreign entry point is always an integer on x8664.
231  (let* ((addr (%reference-external-entry-point (load-time-value (external "__NSRaiseError")))))
232    (if (< addr 0)                      ;unlikely
233      (setf (%%get-signed-longlong return-value-pointer -24) addr)
234      (setf (%%get-unsigned-longlong return-value-pointer -24) addr)))
235  nil)
236
237
238
239)
240
241
242)
243
244
245
246(defun open-main-bundle ()
247  (send (@class ns-bundle) 'main-bundle))
248
249;;; Create a new immutable dictionary just like src, replacing the
250;;; value of each key in key-value-pairs with the corresponding value.
251(defun copy-dictionary (src &rest key-value-pairs)
252  (declare (dynamic-extent key-value-pairs))
253  ;(#_NSLog #@"src = %@" :id src)
254  (let* ((count (send src 'count))
255         (enum (send src 'key-enumerator))
256         (keys (send (@class "NSMutableArray") :array-with-capacity count))
257         (values (send (@class "NSMutableArray") :array-with-capacity count)))
258    (loop
259        (let* ((nextkey (send enum 'next-object)))
260          (when (%null-ptr-p nextkey)
261            (return))
262          (do* ((kvps key-value-pairs (cddr kvps))
263                (newkey (car kvps) (car kvps))
264                (newval (cadr kvps) (cadr kvps)))
265               ((null kvps)
266                ;; Copy the key, value pair from the src dict
267                (send keys :add-object nextkey)
268                (send values :add-object (send src :object-for-key nextkey)))
269            (when (send nextkey :is-equal-to-string  newkey)
270              (send keys :add-object nextkey)
271              (send values :add-object newval)
272              (return)))))
273    (make-objc-instance 'ns-dictionary
274                        :with-objects values
275                        :for-keys keys)))
276
277
278(defun nsobject-description (nsobject)
279  "Returns a lisp string that describes nsobject.  Note that some
280NSObjects describe themselves in more detail than others."
281  (with-autorelease-pool
282      (lisp-string-from-nsstring  (send nsobject 'description))))
283
284
285
286
287;;; This can fail if the nsstring contains non-8-bit characters.
288(defun lisp-string-from-nsstring-substring (nsstring start length)
289  (%stack-block ((cstring (1+ length)))
290    (send nsstring
291          :get-c-string cstring
292          :max-length length
293          :range (ns-make-range start length)
294          :remaining-range (%null-ptr))
295    (%get-cstring cstring)))
296
297(def-standard-initial-binding *listener-autorelease-pool* nil)
298
299(setq *listener-autorelease-pool* (create-autorelease-pool))
300
301(define-toplevel-command :global rap () "Release and reestablish *LISTENER-AUTORELEASE-POOL*"
302  (when (eql *break-level* 0)
303    (without-interrupts
304     (when (boundp '*listener-autorelease-pool*)
305       (let* ((old *listener-autorelease-pool*))
306         (if old (release-autorelease-pool old))
307         (setq *listener-autorelease-pool* (create-autorelease-pool)))))))
308
309#+apple-objc
310(defun show-autorelease-pools ()
311  (objc-message-send (@class ns-autorelease-pool) "showPools" :void))
312
313#+gnu-objc
314(defun show-autorelease-pools ()
315  (do* ((current (objc-message-send (@class ns-autorelease-pool) "currentPool")
316                 (objc-message-send current "_parentAutoreleasePool"))
317        (i 0 (1+ i)))
318       ((%null-ptr-p current) (values))
319    (format t "~& ~d : ~a [~d]"
320            i
321            (nsobject-description current)
322            (pref current :<NSA>utorelease<P>ool._released_count))))
323
324(define-toplevel-command :global sap () "Log information about current thread's autorelease-pool(s) to C's standard error stream"
325  (show-autorelease-pools))
326
327(define-toplevel-command :global kap () "Release (but don't reestablish) *LISTENER-AUTORELEASE-POOL*"
328  (when (eql *break-level* 0)
329    (without-interrupts
330     (when (boundp '*listener-autorelease-pool*)
331       (let* ((p *listener-autorelease-pool*))
332         (setq *listener-autorelease-pool* nil)
333         (release-autorelease-pool p))))))
334
335;;; Use the interfaces for an add-on ObjC framework.  We need to
336;;; tell the bridge to reconsider what it knows about the type
337;;; signatures of ObjC messages, since the new headers may define
338;;; a method whose type signature differs from the message's existing
339;;; methods.  (This probably doesn't happen too often, but it's
340;;; possible that some SENDs that have already been compiled would
341;;; need to be recompiled with that augmented method type info, e.g.,
342;;; because ambiguity was introduced.)
343
344(defun augment-objc-interfaces (dirname)
345  (use-interface-dir dirname)
346  (update-objc-method-info))
347
348;;; A list of "standard" locations which are known to contain
349;;; framework bundles.  We should look in ~/Library/Frameworks/" first,
350;;; if it exists.
351(defparameter *standard-framework-directories*
352  (list #p"/Library/Frameworks/"
353        #p"/System/Library/Frameworks/"))
354
355
356
357;;; This has to run during application (re-)initializtion, so it
358;;; uses lower-level bridge features.
359(defun %reload-objc-framework (path)
360  (when (probe-file path)
361    (let* ((namestring (native-translated-namestring path)))
362      (with-cstrs ((cnamestring namestring))
363        (with-nsstr (nsnamestring cnamestring (length namestring))
364          (with-autorelease-pool
365              (let* ((bundle (send (@class "NSBundle")
366                                   :bundle-with-path nsnamestring)))
367                (unless (%null-ptr-p bundle)
368                  (coerce-from-bool
369                   (objc-message-send bundle "load" :<BOOL>))))))))))
370
371
372(defun load-objc-extension-framework (name)
373  (let* ((dirs *standard-framework-directories*)
374         (home-frameworks (make-pathname :defaults nil
375                                         :directory
376                                         (append (pathname-directory
377                                                  (user-homedir-pathname))
378                                                 '("Library" "Frameworks"))))
379         (fname (list (format nil "~a.framework" name))))
380    (when (probe-file home-frameworks)
381      (pushnew home-frameworks dirs :test #'equalp))
382    (dolist (d dirs)
383      (let* ((path (probe-file (make-pathname :defaults nil
384                                              :directory (append (pathname-directory d)
385                                                                 fname)))))
386        (when path
387          (let* ((namestring (native-translated-namestring path)))
388            (with-cstrs ((cnamestring namestring))
389              (with-nsstr (nsnamestring cnamestring (length namestring))
390                (with-autorelease-pool
391                    (let* ((bundle (send (find-class 'ns:ns-bundle)
392                                         :bundle-with-path nsnamestring))
393                           (winning (unless (%null-ptr-p bundle)
394                                      (or t
395                                          (send (the ns:ns-bundle bundle) 'load)))))
396                      (when winning
397                        (let* ((libpath (send bundle 'executable-path)))
398                          (unless (%null-ptr-p libpath)
399                            (open-shared-library (lisp-string-from-nsstring
400                                                  libpath))))
401                        (send (the ns:ns-bundle bundle) 'load)
402                        (pushnew path *extension-framework-paths*
403                                 :test #'equalp)
404                        (map-objc-classes)
405                        ;; Update info about init messages.
406                        (register-objc-init-messages))
407                      (return winning)))))))))))
408
409                     
410(defmethod print-object ((p ns:protocol) stream)
411  (print-unreadable-object (p stream :type t)
412    (format stream "~a (#x~x)"
413            (%get-cstring (send p 'name))
414            (%ptr-to-int p))))
415
416                                         
417
418
419(provide "OBJC-SUPPORT")
Note: See TracBrowser for help on using the repository browser.