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

Last change on this file since 14821 was 14821, checked in by gb, 9 years ago

Move along. Nothing to see here.

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