Changeset 6227


Ignore:
Timestamp:
Apr 8, 2007, 9:32:35 AM (18 years ago)
Author:
Gary Byers
Message:

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.

File:
1 edited

Legend:

Unmodified
Added
Removed

  • trunk/ccl/examples/objc-support.lisp

    r5937 r6227  
    77
    88(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)
     9  (#/alloc class))
     10
     11(defun conforms-to-protocol (thing protocol)
     12  (#/conformsToProtocol: thing (objc-protocol-address protocol)))
     13
     14
     15
    2616
    2717#+apple-objc
    … …  
    3424           ((= i n) (values))
    3525        (declare (fixnum i))
    36         (funcall fn (%get-ptr buffer (the fixnum  (ash i target::word-shift))))))))
     26        (funcall fn (paref buffer (:* :id) i))))))
     27
     28#+apple-objc
     29(defun count-objc-classes ()
     30  (#_objc_getClassList (%null-ptr) 0)) 
    3731
    3832#+gnu-objc
    … …  
    4539          (funcall fn class))))))
    4640
     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
    4750(defun %note-protocol (p)
    4851  (with-macptrs ((cname (objc-message-send p "name" :address)))
    … …  
    5154      (declare (dynamic-extent name))
    5255      (%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      (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))))
    5664
    5765(defun note-class-protocols (class)
    … …  
    8088       (note-class-protocols class)
    8189       (install-foreign-objc-class class lookup-in-database-p))))
    82  
    83 
    84 (map-objc-classes)
     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)
    85102(register-objc-init-messages)
    86103
    … …  
    132149  (:metaclass ns::+ns-object))
    133150
    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)
     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))
    143178  (with-slots (condition) self
    144179    (if condition
    145180      (%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              
     181      (call-next-method))))
     182
     183(objc:defmethod #/description ((self ns-lisp-exception))
     184  (#/stringWithFormat: ns:ns-string #@"Lisp exception: %@" (#/reason self)))
     185
     186
    156187                     
    157188(defun ns-exception->lisp-condition (nsexception)
    … …  
    167198  ;;; Create an NSLispException with a lispid that encapsulates
    168199  ;;; this condition.
    169   ;;;
    170 
    171 
    172   #|(dbg (format nil "~a" c))|#
     200
     201  ;; (dbg (format nil "~a" c))
    173202  ;;(#_NSLog #@"Lisp exception: %@" :id (%make-nsstring (format nil "~a" c)))
    174203  (make-instance 'ns-lisp-exception :condition c))
    175  
    176 
    177204
    178205
    … …  
    245272
    246273(defun open-main-bundle ()
    247   (send (@class ns-bundle) 'main-bundle))
     274  (#/mainBundle ns:ns-bundle))
    248275
    249276;;; Create a new immutable dictionary just like src, replacing the
    … …  
    252279  (declare (dynamic-extent key-value-pairs))
    253280  ;(#_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)))
     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)))
    258285    (loop
    259         (let* ((nextkey (send enum 'next-object)))
     286        (let* ((nextkey (#/nextObject enum)))
    260287          (when (%null-ptr-p nextkey)
    261288            (return))
    … …  
    265292               ((null kvps)
    266293                ;; 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)
     294                (#/addObject: keys nextkey)
     295                (#/addObject: values (#/objectForKey: src nextkey)))
     296            (when (#/isEqualToString: nextkey newkey)
     297              (#/addObject: keys nextkey)
     298              (#/addObject: values newval)
    272299              (return)))))
    273     (make-objc-instance 'ns-dictionary
    274                         :with-objects values
    275                         :for-keys keys)))
     300    (make-instance 'ns:ns-dictionary
     301                   :with-objects values
     302                   :for-keys keys)))
    276303
    277304
    … …  
    280307NSObjects describe themselves in more detail than others."
    281308  (with-autorelease-pool
    282       (lisp-string-from-nsstring  (send nsobject 'description))))
     309      (lisp-string-from-nsstring  (#/description nsobject))))
    283310
    284311
    … …  
    288315(defun lisp-string-from-nsstring-substring (nsstring start length)
    289316  (%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)))
     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))))
    296321
    297322(def-standard-initial-binding *listener-autorelease-pool* nil)
    … …  
    389414              (with-nsstr (nsnamestring cnamestring (length namestring))
    390415                (with-autorelease-pool
    391                     (let* ((bundle (send (find-class 'ns:ns-bundle)
    392                                          :bundle-with-path nsnamestring))
     416                    (let* ((bundle (#/bundleWithPath: ns:ns-bundle nsnamestring))
    393417                           (winning (unless (%null-ptr-p bundle)
    394                                       (or t
    395                                           (send (the ns:ns-bundle bundle) 'load)))))
     418                                      t)))
    396419                      (when winning
    397                         (let* ((libpath (send bundle 'executable-path)))
     420                        (let* ((libpath (#/executablePath bundle)))
    398421                          (unless (%null-ptr-p libpath)
    399422                            (open-shared-library (lisp-string-from-nsstring
    400423                                                  libpath))))
    401                         (send (the ns:ns-bundle bundle) 'load)
     424                        (#/load bundle)
    402425                        (pushnew path *extension-framework-paths*
    403426                                 :test #'equalp)
    … …  
    407430                      (return winning)))))))))))
    408431
     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
    409438                     
    410439(defmethod print-object ((p ns:protocol) stream)
    411440  (print-unreadable-object (p stream :type t)
    412441    (format stream "~a (#x~x)"
    413             (%get-cstring (send p 'name))
     442            (%get-cstring (#/name p))
    414443            (%ptr-to-int p))))
    415444
Note: See TracChangeset for help on using the changeset viewer.