Ignore:
Timestamp:
Sep 16, 2010, 1:36:09 PM (9 years ago)
Author:
gb
Message:

Make #/ be less sensitive to the readtable. Cache information about
the initarg keywords that correspond to an ObjC "init" message on a
per-class basis. Use this cached information in ALLOCATE-INSTANCE of
OBJC:OBJC-CLASS; this incidentally allows the use of initargs that're
neither associated with a slot nor used to select an ObjC init message
(and allows the latter to be specified in any order.) Export
WITH-AUTORELEASE-POOL, MAKE-NSSTRING (with no #\%),
LISP-STRING-FROM-NSSTRING, and WITH-AUTORELEASED-NSSTRINGS from the OBJC
package (and, where applicable, reimport them into the CCL package.)

File:
1 edited

Legend:

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

    r14203 r14263  
    106106(register-objc-class-decls)
    107107(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
    108126(register-objc-init-messages)
    109127(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)))))
    110191
    111192#+gnu-objc
     
    136217    (reset-objc-class-count)))
    137218
    138 (defun retain-obcj-object (x)
    139   (objc-message-send x "retain"))
    140219
    141220
     
    204283(pushnew 'recognize-objc-exception *foreign-error-condition-recognizers*)
    205284
    206 (defun %make-nsstring (string)
     285(defun objc:make-nsstring (string)
    207286  (with-encoded-cstrs :utf-8 ((s string))
    208287    (#/initWithUTF8String: (#/alloc ns:ns-string) s)))
     288
     289(defun %make-nsstring (string)
     290  (objc:make-nsstring string))
    209291
    210292(defmacro with-autoreleased-nsstring ((nsstring lisp-string) &body body)
     
    213295     ,@body))
    214296
    215 (defmacro with-autoreleased-nsstrings (speclist &body body)
     297(defmacro objc:with-autoreleased-nsstrings (speclist &body body)
    216298  (with-specs-aux 'with-autoreleased-nsstring speclist body))
    217299
     
    230312
    231313
    232 #-ascii-only
    233 (progn
    234 #-windows-target
    235314(defun lisp-string-from-nsstring (nsstring)
    236   ;; The NSData object created here is autoreleased.
    237   (let* ((data (#/dataUsingEncoding:allowLossyConversion:
    238                 nsstring
    239                 #+little-endian-target #x9c000100
    240                 #+big-endian-target #x98000100
    241                 nil)))
    242     (unless (%null-ptr-p data)
    243       (let* ((nbytes (#/length data))
    244              (string (make-string (ash nbytes -2))))
    245         ;; BLT the 4-byte code-points from the NSData object
    246         ;; to the string, return the string.
    247         (%copy-ptr-to-ivector (#/bytes data) 0 string 0 nbytes)))))
    248 
    249 #+windows-target
    250 (defun lisp-string-from-nsstring (nsstring)
    251   (let* ((n (#/length nsstring)))
    252     (%stack-block ((buf (* (1+ n) (record-length :unichar))))
    253       (#/getCharacters: nsstring buf)
    254       (setf (%get-unsigned-word buf (+ n n)) 0)
    255       (%get-native-utf-16-cstring buf))))
    256        
    257 )
    258 
    259 #+ascii-only
    260 (defun lisp-string-from-nsstring (nsstring)
    261   (with-macptrs (cstring)
    262     (%setf-macptr cstring
    263                   (#/cStringUsingEncoding: nsstring #$NSASCIIStringEncoding))
    264     (unless (%null-ptr-p cstring)
    265       (%get-cstring cstring))))
     315  ;; The value returned by #/UTF8String is autoreleased.
     316  (%get-utf-8-cstring (#/UTF8String nsstring)))
     317
     318
     319     
     320
     321
    266322
    267323
     
    454510
    455511
    456 ;;; This can fail if the nsstring contains non-8-bit characters.
    457512(defun lisp-string-from-nsstring-substring (nsstring start length)
    458   (%stack-block ((cstring (1+ length)))
    459     (#/getCString:maxLength:range:remainingRange:
    460        nsstring  cstring  length (ns:make-ns-range start length) +null-ptr+)
    461     (%get-cstring cstring)))
     513  (let* ((substring (#/substringWithRange: nsstring (ns:make-ns-range start length))))
     514    (prog1
     515        (lisp-string-from-nsstring substring)
     516      (#/release substring))))
    462517
    463518(def-standard-initial-binding *listener-autorelease-pool* nil)
Note: See TracChangeset for help on using the changeset viewer.