source: trunk/source/objc-bridge/objc-support.lisp @ 14265

Last change on this file since 14265 was 14265, checked in by rme, 9 years ago

In lisp-string-from-nsstring-substring, don't release already
autoreleased substring instance.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 25.0 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#+(or apple-objc cocotron-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#+(or apple-objc cocotron-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  #-(or apple-objc-2.0 cocotron-objc)
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  #+(or apple-objc-2.0 cocotron-objc)
76  (rlet ((p-out-count :int 0))
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       (lock (make-lock)))
93  (declare (fixnum nclasses))
94  (defun maybe-map-objc-classes (&optional use-db)
95    (with-lock-grabbed (lock)
96      (let* ((new (count-objc-classes)))
97        (declare (fixnum new))
98        (unless (= nclasses new)
99          (setq nclasses new)
100          (map-objc-classes use-db))
101        t)))
102  (defun reset-objc-class-count ()
103    (with-lock-grabbed (lock)
104      (setq nclasses 0))))
105
106(register-objc-class-decls)
107(maybe-map-objc-classes t)
108
109
110(defvar *class-init-keywords* (make-hash-table))
111
112(defun process-init-message (message-info)
113  (let* ((keys (objc-to-lisp-init (objc-message-info-message-name message-info))))
114    (when keys
115      (let* ((keyinfo (cons keys (objc-message-info-lisp-name message-info))))
116        (dolist (method (objc-message-info-methods message-info))
117          (when (and (eq :id (objc-method-info-result-type method))
118                     (let* ((flags (objc-method-info-flags method)))
119                       (not (or (memq :class flags)
120                                (memq :protocol flags)))))
121            (let* ((class (canonicalize-registered-class
122                           (find-objc-class (objc-method-info-class-name method)))))
123              (pushnew keyinfo (gethash class *class-init-keywords*)
124                       :test #'equal))))))))
125
126(register-objc-init-messages)
127(register-objc-set-messages)
128
129
130
131
132
133(defun all-init-keywords-for-class (c)
134  (let* ((keyinfo ()))
135    (dolist (class (class-precedence-list c))
136      (when (eq class ns:ns-object)
137        (return keyinfo))
138      (dolist (class-keys (gethash class *class-init-keywords*))
139        (pushnew class-keys keyinfo :test #'equal)))))
140
141(defun send-init-message-for-class (class initargs)
142  (let* ((all-keywords-for-class (all-init-keywords-for-class class)))
143    (multiple-value-bind (initfunction args)
144        (if all-keywords-for-class
145          (let* ((candidate-functions ())
146                 (candidate-arglists ())
147                 (missing-keyword (cons nil nil)))
148            (declare (dynamic-extent missing-keyword))
149            (dolist (keys-and-function all-keywords-for-class)
150              (collect ((arglist))
151                (destructuring-bind (keys . function) keys-and-function
152                  (dolist (key keys (progn (push function candidate-functions)
153                                           (push (arglist) candidate-arglists)))
154                    (let* ((val (getf initargs key missing-keyword)))
155                      (if (eq missing-keyword val)
156                        (return)
157                        (arglist val)))))))
158            (if candidate-functions
159              (if (null (cdr candidate-functions))
160                (values (car candidate-functions) (car candidate-arglists))
161                ;; Pick the longest match, if that's unique.  If there's
162                ;; no unique longest match, complain.
163                (let* ((maxlen 0)
164                       (maxfun ())
165                       (maxargs ())
166                       (duplicate-match nil))
167                  (declare (fixnum maxlen))
168                  (do* ((functions candidate-functions (cdr functions))
169                        (arglists candidate-arglists (cdr arglists)))
170                       ((null functions)
171                        (if duplicate-match
172                          (values nil nil)
173                          (values maxfun maxargs)))
174                    (let* ((arglist (car arglists))
175                           (n (length arglist)))
176                      (declare (fixnum n))
177                      (if (> n maxlen)
178                        (setq n maxlen
179                              duplicate-match nil
180                              maxargs arglist
181                              maxfun (car functions))
182                        (if (= n maxlen)
183                          (setq duplicate-match t)))))))
184              (values '#/init nil)))
185          (values '#/init nil))
186      (if initfunction
187        (let* ((instance (apply initfunction (#/alloc class) args)))
188          (ensure-lisp-slots instance class)
189          instance)
190        (error "Can't determine ObjC init function for class ~s and initargs ~s." class initargs)))))
191
192#+gnu-objc
193(defun iterate-over-class-methods (class method-function)
194  (do* ((mlist (pref class :objc_class.methods)
195               (pref mlist :objc_method_list.method_next)))
196       ((%null-ptr-p mlist))
197    (do* ((n (pref mlist :objc_method_list.method_count))
198          (i 0 (1+ i))
199          (method (pref mlist :objc_method_list.method_list)
200                  (%incf-ptr method (record-length :objc_method))))
201         ((= i n))
202      (declare (fixnum i n))
203      (funcall method-function method class))))
204
205#+gnu-objc
206(progn
207  ;; Er, um ... this needs lots-o-work.
208  (let* ((objc-class-count 0))
209    (defun reset-objc-class-count () (setq objc-class-count 0))
210    (defun note-all-library-methods (method-function)
211      (do* ((i objc-class-count (1+ i))
212            (class (id->objc-class i) (id->objc-class i)))
213           ((eq class 0))
214        (iterate-over-class-methods class method-function)
215        (iterate-over-class-methods (id->objc-metaclass i) method-function))))
216  (def-ccl-pointers revive-objc-classes ()
217    (reset-objc-class-count)))
218
219
220
221#+apple-objc-2.0
222(progn
223(defun setup-objc-exception-globals ()
224  (flet ((set-global (offset name)
225           (setf (%get-ptr (%int-to-ptr (+ (target-nil-value) (%kernel-global-offset offset))))
226                 (foreign-symbol-address name))))
227    (set-global 'objc-2-personality "___objc_personality_v0")
228    (set-global 'objc-2-begin-catch "objc_begin_catch")
229    (set-global 'objc-2-end-catch "objc_end_catch")
230    (set-global 'unwind-resume "__Unwind_Resume")))
231
232
233(def-ccl-pointers setup-objc-exception-handling ()
234  (setup-objc-exception-globals))
235
236(setup-objc-exception-globals)
237)
238
239
240(defvar *condition-id-map* (make-id-map) "Map lisp conditions to small integers")
241
242;;; Encapsulate an NSException in a lisp condition.
243(define-condition ns-exception (error)
244  ((ns-exception :initarg :ns-exception :accessor ns-exception))
245  (:report (lambda (c s)
246             (format s "Objective-C runtime exception: ~&~a"
247                     (nsobject-description (ns-exception c))))))
248
249(defun ensure-dealloc-method-for-class (class)
250  (let* ((direct-slots (class-direct-slots class))
251         (effective-slots (class-slots class)))
252    (when (and (dolist (d direct-slots)
253                 (when (and (typep d 'standard-direct-slot-definition)
254                            (eq :instance (slot-definition-allocation d)))
255                   (return t)))
256               (dolist (e effective-slots t)
257                 (when (and (typep e 'standard-effective-slot-definition)
258                            (eq :instance (slot-definition-allocation e))
259                            (not (find (slot-definition-name e)
260                                       direct-slots
261                                         :key #'slot-definition-name
262                                         :test #'eq)))
263                   (return))))
264      (eval `(objc:defmethod (#/dealloc :void) ((self ,(class-name class)))
265              (objc:remove-lisp-slots self)
266              (call-next-method))))))
267
268(eval-when (:compile-toplevel :execute)
269  (declaim (ftype (function (&rest t) t) objc-callback-error-return)))
270
271(defclass ns-lisp-exception (ns::ns-exception)
272    ((condition :initarg :condition :initform nil :reader ns-lisp-exception-condition))
273  (:metaclass ns::+ns-object))
274
275(objc:defmethod #/init ((self ns-lisp-exception))
276  (#/initWithName:reason:userInfo: self #@"lisp exception" #@"lisp exception" +null-ptr+))
277
278
279(defun recognize-objc-exception (x)
280  (if (typep x 'ns:ns-exception)
281    (ns-exception->lisp-condition x)))
282
283(pushnew 'recognize-objc-exception *foreign-error-condition-recognizers*)
284
285(defun objc:make-nsstring (string)
286  (with-encoded-cstrs :utf-8 ((s string))
287    (#/initWithUTF8String: (#/alloc ns:ns-string) s)))
288
289(defun %make-nsstring (string)
290  (objc:make-nsstring string))
291
292(defmacro with-autoreleased-nsstring ((nsstring lisp-string) &body body)
293  `(let* ((,nsstring (%make-nsstring ,lisp-string)))
294     (#/autorelease ,nsstring)
295     ,@body))
296
297(defmacro objc:with-autoreleased-nsstrings (speclist &body body)
298  (with-specs-aux 'with-autoreleased-nsstring speclist body))
299
300(defun retain-objc-instance (instance)
301  (#/retain instance))
302
303;;; May have to create/release autorelease pools before the bridge
304;;; is fully reinitialized, so use low-level OBJC-MESSAGE-SEND
305;;; and @class.
306(defun create-autorelease-pool ()
307  (objc-message-send
308   (objc-message-send (@class "NSAutoreleasePool") "alloc") "init"))
309
310(defun release-autorelease-pool (p)
311  (objc-message-send p "release" :void))
312
313
314(defun lisp-string-from-nsstring (nsstring)
315  ;; The value returned by #/UTF8String is autoreleased.
316  (%get-utf-8-cstring (#/UTF8String nsstring)))
317
318
319     
320
321
322
323
324(objc:defmethod #/reason ((self ns-lisp-exception))
325  (with-slots (condition) self
326    (if condition
327      (#/autorelease (%make-nsstring (format nil "~A" condition)))
328      (call-next-method))))
329
330(objc:defmethod #/description ((self ns-lisp-exception))
331  (#/stringWithFormat: ns:ns-string #@"Lisp exception: %@" (#/reason self)))
332
333
334                     
335(defun ns-exception->lisp-condition (nsexception)
336  (if (typep nsexception 'ns-lisp-exception)
337    (ns-lisp-exception-condition nsexception)
338    (make-condition 'ns-exception :ns-exception nsexception)))
339
340
341(defmethod ns-exception ((c condition))
342  "Map a lisp condition object to an NSException.  Note that instances
343of the NS-EXCEPTION condition class implement this by accessing an
344instance variable."
345  ;;; Create an NSLispException with a lispid that encapsulates
346  ;;; this condition.
347
348  ;; (dbg (format nil "~a" c))
349  ;;(#_NSLog #@"Lisp exception: %@" :id (%make-nsstring (format nil "~a" c)))
350  (make-instance 'ns-lisp-exception :condition c))
351
352
353
354#+(or apple-objc cocotron-objc)         ; not really
355(progn
356
357
358#+ppc-target
359(defun objc-callback-error-return (condition return-value-pointer return-address-pointer)
360  ;; On PPC, the "address" of an external entry point is always
361  ;; aligned on a 32-bit word boundary.  On PPC32, it can always
362  ;; be represented as a fixnum; on PPC64, it might be a pointer
363  ;; instead.
364  ;; Note that this clobbers the actual (foreign) return address,
365  ;; replacing it with the address of #__NSRaiseError.  Note also
366  ;; that storing the NSException object as the return value has
367  ;; the desired effect of causing #__NSRaiseError to be called
368  ;; with that NSException as its argument (because r3 is used both
369  ;; as the canonical return value register and used to pass the
370  ;; first argument on PPC.)
371  (process-debug-condition *current-process* condition (%get-frame-ptr))
372  (let* ((addr (%reference-external-entry-point (load-time-value (external "__NSRaiseError")))))
373    (if (typep addr 'fixnum)
374      (%set-object return-address-pointer 0 addr)
375      (setf (%get-ptr return-address-pointer 0) addr)))
376  (setf (%get-ptr return-value-pointer 0) (ns-exception condition))
377  nil)
378
379#+x8664-target
380(progn
381(defloadvar *x8664-objc-callback-error-return-trampoline*
382    (let* ((code-bytes '(#x48 #x89 #xc7      ; movq %rax %rdi
383                         #x66 #x48 #x0f #x7e #xc0 ; movd %xmm0,%rax
384                         #x52                ; pushq %rdx
385                         #xff #xe0))         ; jmp *rax
386           (nbytes (length code-bytes))
387           (ptr (%allocate-callback-pointer 16)))
388      (dotimes (i nbytes ptr)
389        (setf (%get-unsigned-byte ptr i) (pop code-bytes)))))
390
391(defun objc-callback-error-return (condition return-value-pointer return-address-pointer) 
392  ;; The callback glue reserves space for %rax at return-value-pointer-8,
393  ;; for %rdx at -16, for %xmm0 at -24.  Store NS-EXCEPTION in the
394  ;; %rax slot, the address of #_objc_exception_throw in the %rdx slot, the
395  ;; original return address in the %xmm0 slot, and force a return to
396  ;; the trampoline code above.
397  (process-debug-condition *current-process* condition (%get-frame-ptr))
398  (setf (%get-ptr return-value-pointer -8) (ns-exception condition)
399        (%get-ptr return-value-pointer -16) (%get-ptr return-address-pointer 0)
400        (%get-ptr return-address-pointer 0) *x8664-objc-callback-error-return-trampoline*)
401  ;; A foreign entry point is always an integer on x8664.
402  (let* ((addr (%reference-external-entry-point (load-time-value (external "_objc_exception_throw")))))
403    (if (< addr 0)                      ;unlikely
404      (setf (%%get-signed-longlong return-value-pointer -24) addr)
405      (setf (%%get-unsigned-longlong return-value-pointer -24) addr)))
406  nil)
407
408
409)
410
411#+x8632-target
412(progn
413
414(defloadvar *x8632-objc-callback-error-return-trampoline*
415    (let* ((code-bytes '(#x83 #xec #x10      ; subl $16,%esp
416                         #x89 #x04 #x24      ; movl %eax,(%esp)
417                         #x52                ; pushl %edx
418                         #xff #xe1))         ; jmp *ecx
419           (nbytes (length code-bytes))
420           (ptr (%allocate-callback-pointer 16)))
421      (dotimes (i nbytes ptr)
422        (setf (%get-unsigned-byte ptr i) (pop code-bytes)))))
423
424(defun objc-callback-error-return (condition return-value-pointer return-address-pointer)
425  (process-debug-condition *current-process* condition (%get-frame-ptr))
426  (let* ((addr (%reference-external-entry-point (load-time-value (external #+cocotron-objc "_NSRaiseException" #-cocotron-objc "__NSRaiseError")))))
427    (setf (%get-unsigned-long return-value-pointer -12 ) addr))
428  (setf (%get-ptr return-value-pointer -8) (ns-exception condition)
429        (%get-ptr return-value-pointer -4) (%get-ptr return-address-pointer)
430        (%get-ptr return-address-pointer) *x8632-objc-callback-error-return-trampoline*)
431  nil)
432)
433
434)
435
436
437
438(defun open-main-bundle ()
439  (#/mainBundle ns:ns-bundle))
440
441;;; Create a new immutable dictionary just like src, replacing the
442;;; value of each key in key-value-pairs with the corresponding value.
443(defun copy-dictionary (src &rest key-value-pairs)
444  (declare (dynamic-extent key-value-pairs))
445  ;(#_NSLog #@"src = %@" :id src)
446  (let* ((count (#/count src))
447         (enum (#/keyEnumerator src))
448         (keys (#/arrayWithCapacity: ns:ns-mutable-array count))
449         (values (#/arrayWithCapacity: ns:ns-mutable-array count)))
450    (loop
451        (let* ((nextkey (#/nextObject enum)))
452          (when (%null-ptr-p nextkey)
453            (return))
454          (do* ((kvps key-value-pairs (cddr kvps))
455                (newkey (car kvps) (car kvps))
456                (newval (cadr kvps) (cadr kvps)))
457               ((null kvps)
458                ;; Copy the key, value pair from the src dict
459                (#/addObject: keys nextkey)
460                (#/addObject: values (#/objectForKey: src nextkey)))
461            (when (#/isEqualToString: nextkey newkey)
462              (#/addObject: keys nextkey)
463              (#/addObject: values newval)
464              (return)))))
465    (make-instance 'ns:ns-dictionary
466                   :with-objects values
467                   :for-keys keys)))
468
469
470
471
472(defparameter *objc-description-max-length* 1024 "Limit on the length of NSObject description strings if non-NIL.")
473
474(defun %cf-instance-p (instance)
475  #-apple-objc (declare (ignore instance))
476  #+apple-objc
477  (> (objc-message-send instance "_cfTypeID" #>CFTypeID) 1))
478 
479
480(defun initialized-nsobject-p (nsobject)
481  (or (objc-class-p nsobject)
482      (objc-metaclass-p nsobject)
483      (has-lisp-slot-vector nsobject)
484      (let* ((cf-p (%cf-instance-p nsobject)) 
485             (isize (if cf-p (external-call "malloc_size" :address nsobject :size_t) (%objc-class-instance-size (#/class nsobject))))
486             (skip (if cf-p (+ (record-length :id) 4 #+64-bit-target 4) (record-length :id))))
487        (declare (fixnum isize skip))
488        (or (> skip isize)
489            (do* ((i skip (1+ i)))
490                 ((>= i isize))
491              (declare (fixnum i))
492              (unless (zerop (the (unsigned-byte 8) (%get-unsigned-byte nsobject i)))
493                (return t)))))))
494 
495(defun nsobject-description (nsobject)
496  "Returns a lisp string that describes nsobject.  Note that some
497NSObjects describe themselves in more detail than others."
498  (if (initialized-nsobject-p nsobject)
499    (with-autorelease-pool
500        (let* ((desc (#/description nsobject)))
501          (if (or (null *objc-description-max-length*)
502                  (< (#/length desc) *objc-description-max-length*))
503            (lisp-string-from-nsstring desc)
504            (ns:with-ns-range (r 0 *objc-description-max-length*)
505              (format nil "~a[...]"(lisp-string-from-nsstring (#/substringWithRange: desc r)))))))
506    "[uninitialized]"))
507
508
509
510
511
512(defun lisp-string-from-nsstring-substring (nsstring start length)
513  (let* ((substring (#/substringWithRange: nsstring (ns:make-ns-range start length))))
514    (lisp-string-from-nsstring substring)))
515
516(def-standard-initial-binding *listener-autorelease-pool* nil)
517
518(setq *listener-autorelease-pool* (create-autorelease-pool))
519
520(define-toplevel-command :global rap () "Release and reestablish *LISTENER-AUTORELEASE-POOL*"
521  (when (eql *break-level* 0)
522    (without-interrupts
523     (when (boundp '*listener-autorelease-pool*)
524       (let* ((old *listener-autorelease-pool*))
525         (if old (release-autorelease-pool old))
526         (setq *listener-autorelease-pool* (create-autorelease-pool)))))))
527
528#+apple-objc
529(defun show-autorelease-pools ()
530  (objc-message-send (@class ns-autorelease-pool) "showPools" :void))
531
532#+gnu-objc
533(defun show-autorelease-pools ()
534  (do* ((current (objc-message-send (@class ns-autorelease-pool) "currentPool")
535                 (objc-message-send current "_parentAutoreleasePool"))
536        (i 0 (1+ i)))
537       ((%null-ptr-p current) (values))
538    (format t "~& ~d : ~a [~d]"
539            i
540            (nsobject-description current)
541            (pref current :<NSA>utorelease<P>ool._released_count))))
542
543#+cocotron-objc
544(defun show-autorelease-pools ()
545  (%string-to-stderr  "No info about current thread's autorelease pools is available"))
546
547(define-toplevel-command :global sap () "Log information about current thread's autorelease-pool(s) to C's standard error stream"
548  (show-autorelease-pools))
549
550(define-toplevel-command :global kap () "Release (but don't reestablish) *LISTENER-AUTORELEASE-POOL*"
551  (when (eql *break-level* 0)
552    (without-interrupts
553     (when (boundp '*listener-autorelease-pool*)
554       (let* ((p *listener-autorelease-pool*))
555         (setq *listener-autorelease-pool* nil)
556         (release-autorelease-pool p))))))
557
558;;; Use the interfaces for an add-on ObjC framework.  We need to
559;;; tell the bridge to reconsider what it knows about the type
560;;; signatures of ObjC messages, since the new headers may define
561;;; a method whose type signature differs from the message's existing
562;;; methods.  (This probably doesn't happen too often, but it's
563;;; possible that some SENDs that have already been compiled would
564;;; need to be recompiled with that augmented method type info, e.g.,
565;;; because ambiguity was introduced.)
566
567(defun augment-objc-interfaces (dirname)
568  (use-interface-dir dirname)
569  (register-objc-class-decls)
570  (update-objc-method-info))
571
572;;; A list of "standard" locations which are known to contain
573;;; framework bundles.  We should look in ~/Library/Frameworks/" first,
574;;; if it exists.
575(defparameter *standard-framework-directories*
576  (list #p"/Library/Frameworks/"
577        #p"/System/Library/Frameworks/"))
578
579
580
581;;; This has to run during application (re-)initializtion, so it
582;;; uses lower-level bridge features.
583(defun %reload-objc-framework (path)
584  (when (probe-file path)
585    (let* ((namestring (native-translated-namestring path)))
586      (with-cstrs ((cnamestring namestring))
587        (with-nsstr (nsnamestring cnamestring (length namestring))
588          (with-autorelease-pool
589              (let* ((bundle (objc-message-send (@class "NSBundle")
590                                                "bundleWithPath:"
591                                                :id nsnamestring :id)))
592                (unless (%null-ptr-p bundle)
593                  (objc-message-send bundle "load" :<BOOL>)))))))))
594
595
596(defun load-objc-extension-framework (name)
597  (let* ((dirs *standard-framework-directories*)
598         (home-frameworks (make-pathname :defaults nil
599                                         :directory
600                                         (append (pathname-directory
601                                                  (user-homedir-pathname))
602                                                 '("Library" "Frameworks"))))
603         (fname (list (format nil "~a.framework" name))))
604    (when (probe-file home-frameworks)
605      (pushnew home-frameworks dirs :test #'equalp))
606    (dolist (d dirs)
607      (let* ((path (probe-file (make-pathname :defaults nil
608                                              :directory (append (pathname-directory d)
609                                                                 fname)))))
610        (when path
611          (let* ((namestring (native-translated-namestring path)))
612            (with-cstrs ((cnamestring namestring))
613              (with-nsstr (nsnamestring cnamestring (length namestring))
614                (with-autorelease-pool
615                    (let* ((bundle (#/bundleWithPath: ns:ns-bundle nsnamestring))
616                           (winning (unless (%null-ptr-p bundle)
617                                      t)))
618                      (when winning
619                        (let* ((libpath (#/executablePath bundle)))
620                          (unless (%null-ptr-p libpath)
621                            (open-shared-library (lisp-string-from-nsstring
622                                                  libpath))))
623                        (#/load bundle)
624                        (pushnew path *extension-framework-paths*
625                                 :test #'equalp)
626                        (map-objc-classes)
627                        ;; Update info about init messages.
628                        (register-objc-init-messages)
629                        (register-objc-set-messages))
630                      (return winning)))))))))))
631
632(defun objc:load-framework (framework-name interfaces-name)
633  (use-interface-dir interfaces-name)
634  (or (load-objc-extension-framework framework-name)
635      (error "Can't load ObjC framework ~s" framework-name))
636  (augment-objc-interfaces interfaces-name))
637
638                     
639(defmethod print-object ((p ns:protocol) stream)
640  (print-unreadable-object (p stream :type t)
641    (format stream "~a (#x~x)"
642            (%get-cstring (#/name p))
643            (%ptr-to-int p))))
644
645                                         
646(defmethod terminate ((instance objc:objc-object))
647  (objc-message-send instance "release"))
648
649
650(provide "OBJC-SUPPORT")
Note: See TracBrowser for help on using the repository browser.