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

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

Use new syntax.
OBJC:LOAD-FRAMEWORK.
Avoid some deprecated C-string stuff (but wimp out and assume ASCII.)
Keep track of objc-class-count, provide MAYBE-MAP-OBJC-CLASSES to
map new classes iff class count changes.
Handle OBJC-PROTOCOLs a bit differently.
Move CGFLOAT definitions, etc. elsewhere.

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