Changeset 15544


Ignore:
Timestamp:
Dec 19, 2012, 10:37:12 PM (7 years ago)
Author:
rme
Message:

Move some code to avoid warning "Undefined function OBJC-PROPAGATE-THROW".

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/objc-bridge/objc-support.lisp

    r15540 r15544  
    257257)
    258258
    259 
    260 (defvar *condition-id-map* (make-id-map) "Map lisp conditions to small integers")
    261 
    262 ;;; Encapsulate an NSException in a lisp condition.
    263 (define-condition ns-exception (error)
    264   ((ns-exception :initarg :ns-exception :accessor ns-exception))
    265   (:report (lambda (c s)
    266              (format s "Objective-C runtime exception: ~&~a"
    267                      (nsobject-description (ns-exception c))))))
    268 
    269 (defun ensure-dealloc-method-for-class (class)
    270   (let* ((direct-slots (class-direct-slots class))
    271          (effective-slots (class-slots class)))
    272     (when (and (dolist (d direct-slots)
    273                  (when (and (typep d 'standard-direct-slot-definition)
    274                             (eq :instance (slot-definition-allocation d)))
    275                    (return t)))
    276                (dolist (e effective-slots t)
    277                  (when (and (typep e 'standard-effective-slot-definition)
    278                             (eq :instance (slot-definition-allocation e))
    279                             (not (find (slot-definition-name e)
    280                                        direct-slots
    281                                          :key #'slot-definition-name
    282                                          :test #'eq)))
    283                    (return))))
    284       (eval `(objc:defmethod (#/dealloc :void) ((self ,(class-name class)))
    285               (objc:remove-lisp-slots self)
    286               (call-next-method))))))
    287 
    288 (eval-when (:compile-toplevel :execute)
    289   (declaim (ftype (function (&rest t) t) objc-callback-error-return)))
    290 
    291 (defclass ns-lisp-exception (ns::ns-exception)
    292     ((condition :initarg :condition :initform nil :reader ns-lisp-exception-condition))
    293   (:metaclass ns::+ns-object))
    294 
    295 (objc:defmethod #/init ((self ns-lisp-exception))
    296   (#/initWithName:reason:userInfo: self #@"lisp exception" #@"lisp exception" +null-ptr+))
    297 
    298 (defclass encapsulated-lisp-throw (ns::ns-exception)
    299     ((id :foreign-type #>NSUInteger))
    300   (:metaclass ns::+ns-object))
    301 
    302 (objc:defmethod #/init ((self encapsulated-lisp-throw))
    303   (#/initWithName:reason:userInfo: self #@"encapsulated throw" #@"encapsulated-throw" +null-ptr+))
    304 
    305 (defun encapsulate-throw-info (info)
    306   (let* ((els (make-instance 'encapsulated-lisp-throw)))
    307     (setf (slot-value els 'id)
    308           (assign-id-map-id *condition-id-map* info))
    309     els))
    310 
    311 (defun recognize-objc-exception (x)
    312   (if (typep x 'encapsulated-lisp-throw)
    313     (apply #'%throw (with-slots (id) x (id-map-object *condition-id-map* id)))
    314     (if (typep x 'ns:ns-exception)
    315       (ns-exception->lisp-condition x))))
    316 
    317 (pushnew 'recognize-objc-exception *foreign-error-condition-recognizers*)
    318 
    319 (defun objc:make-nsstring (string)
    320   (with-encoded-cstrs :utf-8 ((s string))
    321     (#/initWithUTF8String: (#/alloc ns:ns-string) s)))
    322 
    323 (defun %make-nsstring (string)
    324   (objc:make-nsstring string))
    325 
    326 (defmacro with-autoreleased-nsstring ((nsstring lisp-string) &body body)
    327   `(let* ((,nsstring (%make-nsstring ,lisp-string)))
    328      (#/autorelease ,nsstring)
    329      ,@body))
    330 
    331 (defmacro objc:with-autoreleased-nsstrings (speclist &body body)
    332   (with-specs-aux 'with-autoreleased-nsstring speclist body))
    333 
    334 (defun retain-objc-instance (instance)
    335   (#/retain instance))
    336 
    337 ;;; May have to create/release autorelease pools before the bridge
    338 ;;; is fully reinitialized, so use low-level OBJC-MESSAGE-SEND
    339 ;;; and @class.
    340 (defun create-autorelease-pool ()
    341   (objc-message-send
    342    (objc-message-send (@class "NSAutoreleasePool") "alloc") "init"))
    343 
    344 (defun release-autorelease-pool (p)
    345   (objc-message-send p "release" :void))
    346 
    347 
    348 (defun lisp-string-from-nsstring (nsstring)
    349   (with-autorelease-pool
    350       ;; It's not clear that it's even possible to lose information
    351       ;; when converting to UTF-8, but allow lossage to occur, just in
    352       ;; case.
    353       (let* ((data (#/dataUsingEncoding:allowLossyConversion:
    354                     nsstring #$NSUTF8StringEncoding t))
    355              (len (#/length data)))
    356         (if (= len 0)
    357           ""
    358           (let* ((bytes (#/bytes data))
    359                  (nchars (utf-8-length-of-memory-encoding bytes len 0))
    360                  (string (make-string nchars)))
    361             (utf-8-memory-decode bytes len 0 string)
    362             string)))))
    363 
    364 
    365 
    366      
    367 
    368 
    369 
    370 
    371 (objc:defmethod #/reason ((self ns-lisp-exception))
    372   (with-slots (condition) self
    373     (if condition
    374       (#/autorelease (%make-nsstring (format nil "~A" condition)))
    375       (call-next-method))))
    376 
    377 (objc:defmethod #/description ((self ns-lisp-exception))
    378   (#/stringWithFormat: ns:ns-string #@"Lisp exception: %@" (#/reason self)))
    379 
    380 
    381                      
    382 (defun ns-exception->lisp-condition (nsexception)
    383   (if (typep nsexception 'ns-lisp-exception)
    384     (ns-lisp-exception-condition nsexception)
    385     (make-condition 'ns-exception :ns-exception nsexception)))
    386 
    387 
    388 (defmethod ns-exception ((c condition))
    389   "Map a lisp condition object to an NSException.  Note that instances
    390 of the NS-EXCEPTION condition class implement this by accessing an
    391 instance variable."
    392   ;;; Create an NSLispException with a lispid that encapsulates
    393   ;;; this condition.
    394 
    395   ;; (dbg (format nil "~a" c))
    396   ;;(#_NSLog #@"Lisp exception: %@" :id (%make-nsstring (format nil "~a" c)))
    397   (make-instance 'ns-lisp-exception :condition c))
    398 
    399 
    400 
    401259#+(or apple-objc cocotron-objc)         ; not really
    402260(progn
     
    505363
    506364)
     365
     366
     367
     368
     369(defvar *condition-id-map* (make-id-map) "Map lisp conditions to small integers")
     370
     371;;; Encapsulate an NSException in a lisp condition.
     372(define-condition ns-exception (error)
     373  ((ns-exception :initarg :ns-exception :accessor ns-exception))
     374  (:report (lambda (c s)
     375             (format s "Objective-C runtime exception: ~&~a"
     376                     (nsobject-description (ns-exception c))))))
     377
     378(defun ensure-dealloc-method-for-class (class)
     379  (let* ((direct-slots (class-direct-slots class))
     380         (effective-slots (class-slots class)))
     381    (when (and (dolist (d direct-slots)
     382                 (when (and (typep d 'standard-direct-slot-definition)
     383                            (eq :instance (slot-definition-allocation d)))
     384                   (return t)))
     385               (dolist (e effective-slots t)
     386                 (when (and (typep e 'standard-effective-slot-definition)
     387                            (eq :instance (slot-definition-allocation e))
     388                            (not (find (slot-definition-name e)
     389                                       direct-slots
     390                                         :key #'slot-definition-name
     391                                         :test #'eq)))
     392                   (return))))
     393      (eval `(objc:defmethod (#/dealloc :void) ((self ,(class-name class)))
     394              (objc:remove-lisp-slots self)
     395              (call-next-method))))))
     396
     397(eval-when (:compile-toplevel :execute)
     398  (declaim (ftype (function (&rest t) t) objc-callback-error-return)))
     399
     400(defclass ns-lisp-exception (ns::ns-exception)
     401    ((condition :initarg :condition :initform nil :reader ns-lisp-exception-condition))
     402  (:metaclass ns::+ns-object))
     403
     404(objc:defmethod #/init ((self ns-lisp-exception))
     405  (#/initWithName:reason:userInfo: self #@"lisp exception" #@"lisp exception" +null-ptr+))
     406
     407(defclass encapsulated-lisp-throw (ns::ns-exception)
     408    ((id :foreign-type #>NSUInteger))
     409  (:metaclass ns::+ns-object))
     410
     411(objc:defmethod #/init ((self encapsulated-lisp-throw))
     412  (#/initWithName:reason:userInfo: self #@"encapsulated throw" #@"encapsulated-throw" +null-ptr+))
     413
     414(defun encapsulate-throw-info (info)
     415  (let* ((els (make-instance 'encapsulated-lisp-throw)))
     416    (setf (slot-value els 'id)
     417          (assign-id-map-id *condition-id-map* info))
     418    els))
     419
     420(defun recognize-objc-exception (x)
     421  (if (typep x 'encapsulated-lisp-throw)
     422    (apply #'%throw (with-slots (id) x (id-map-object *condition-id-map* id)))
     423    (if (typep x 'ns:ns-exception)
     424      (ns-exception->lisp-condition x))))
     425
     426(pushnew 'recognize-objc-exception *foreign-error-condition-recognizers*)
     427
     428(defun objc:make-nsstring (string)
     429  (with-encoded-cstrs :utf-8 ((s string))
     430    (#/initWithUTF8String: (#/alloc ns:ns-string) s)))
     431
     432(defun %make-nsstring (string)
     433  (objc:make-nsstring string))
     434
     435(defmacro with-autoreleased-nsstring ((nsstring lisp-string) &body body)
     436  `(let* ((,nsstring (%make-nsstring ,lisp-string)))
     437     (#/autorelease ,nsstring)
     438     ,@body))
     439
     440(defmacro objc:with-autoreleased-nsstrings (speclist &body body)
     441  (with-specs-aux 'with-autoreleased-nsstring speclist body))
     442
     443(defun retain-objc-instance (instance)
     444  (#/retain instance))
     445
     446;;; May have to create/release autorelease pools before the bridge
     447;;; is fully reinitialized, so use low-level OBJC-MESSAGE-SEND
     448;;; and @class.
     449(defun create-autorelease-pool ()
     450  (objc-message-send
     451   (objc-message-send (@class "NSAutoreleasePool") "alloc") "init"))
     452
     453(defun release-autorelease-pool (p)
     454  (objc-message-send p "release" :void))
     455
     456
     457(defun lisp-string-from-nsstring (nsstring)
     458  (with-autorelease-pool
     459      ;; It's not clear that it's even possible to lose information
     460      ;; when converting to UTF-8, but allow lossage to occur, just in
     461      ;; case.
     462      (let* ((data (#/dataUsingEncoding:allowLossyConversion:
     463                    nsstring #$NSUTF8StringEncoding t))
     464             (len (#/length data)))
     465        (if (= len 0)
     466          ""
     467          (let* ((bytes (#/bytes data))
     468                 (nchars (utf-8-length-of-memory-encoding bytes len 0))
     469                 (string (make-string nchars)))
     470            (utf-8-memory-decode bytes len 0 string)
     471            string)))))
     472
     473
     474
     475     
     476
     477
     478
     479
     480(objc:defmethod #/reason ((self ns-lisp-exception))
     481  (with-slots (condition) self
     482    (if condition
     483      (#/autorelease (%make-nsstring (format nil "~A" condition)))
     484      (call-next-method))))
     485
     486(objc:defmethod #/description ((self ns-lisp-exception))
     487  (#/stringWithFormat: ns:ns-string #@"Lisp exception: %@" (#/reason self)))
     488
     489
     490                     
     491(defun ns-exception->lisp-condition (nsexception)
     492  (if (typep nsexception 'ns-lisp-exception)
     493    (ns-lisp-exception-condition nsexception)
     494    (make-condition 'ns-exception :ns-exception nsexception)))
     495
     496
     497(defmethod ns-exception ((c condition))
     498  "Map a lisp condition object to an NSException.  Note that instances
     499of the NS-EXCEPTION condition class implement this by accessing an
     500instance variable."
     501  ;;; Create an NSLispException with a lispid that encapsulates
     502  ;;; this condition.
     503
     504  ;; (dbg (format nil "~a" c))
     505  ;;(#_NSLog #@"Lisp exception: %@" :id (%make-nsstring (format nil "~a" c)))
     506  (make-instance 'ns-lisp-exception :condition c))
     507
    507508
    508509
Note: See TracChangeset for help on using the changeset viewer.