Changeset 14263


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.)

Location:
trunk/source/objc-bridge
Files:
5 edited

Legend:

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

    r13969 r14263  
    366366;;; about it.
    367367(defun check-objc-message-name (string)
    368   (dotimes (i (length string))
    369     (let* ((ch (char string i)))
    370       (unless (or (alpha-char-p ch)
    371                   (digit-char-p ch 10)
    372                   (eql ch #\:)
    373                   (eql ch #\_))
    374         (error "Illegal character ~s in ObjC message name ~s"
    375                ch (copy-seq string)))))
    376   (when (and (position #\: string)
    377              (not (eql (char string (1- (length string))) #\:)))
    378     (error "ObjC message name ~s contains colons, but last character is not a colon" (copy-seq string))))
     368  (let* ((initial-p t)
     369         (colon nil)
     370         (lastch nil))
     371    (dotimes (i (length string))
     372      (let* ((ch (char string i)))
     373        (if (eql ch #\:)
     374          (setq initial-p t colon t)
     375          (progn
     376            (if (and initial-p (digit-char-p ch 10))
     377              (error "Digit ~d not allowed at position ~d of ObjC message name ~s."
     378                     ch i (copy-seq string)))
     379            (setq initial-p nil)))
     380        (setq lastch ch)))
     381    (when (and colon
     382               (not (eql lastch #\:)))
     383      (error "ObjC message name ~s contains colons, but last character is not a colon" (copy-seq string)))))
    379384     
    380385
     
    385390                              (lambda (stream subchar numarg)
    386391                                (declare (ignorable subchar numarg))
    387                                 (let* ((token (make-array 16 :element-type 'character :fill-pointer 0 :adjustable t))
    388                                        (attrtab (rdtab.ttab *readtable*)))
    389                                   (when (peek-char t stream nil nil)
    390                                     (loop
    391                                       (multiple-value-bind (char attr)
    392                                           (%next-char-and-attr stream attrtab)
    393                                         (unless (eql attr $cht_cnst)
    394                                           (when char (unread-char char stream))
    395                                           (return))
    396                                         (vector-push-extend char token))))
     392                                (let* ((token (make-array 16 :element-type 'character :fill-pointer 0 :adjustable t)))
     393                                  (loop
     394                                    (let* ((char (read-char stream nil nil)))
     395                                      (if (or (eql char #\:)
     396                                              (eql char #\_)
     397                                              (digit-char-p char 36))
     398                                        (vector-push-extend char token)
     399                                        (progn
     400                                          (when char
     401                                            (unread-char char stream))
     402                                          (return)))))
    397403                                  (unless *read-suppress*
    398404                                    (unless (> (length token) 0)
     
    11231129               (not was-ambiguous))
    11241130        (warn "previously declared methods on ~s all had the same type signature, but ~s introduces ambiguity" message-name method-info))
    1125            
     1131      (when (string= message-name "init" :end1 (min 4 (length message-name)))
     1132        (process-init-message info))
    11261133      (objc-method-info-signature method-info))))
    11271134
     
    14361443
    14371444
     1445
    14381446;;; Provide the BRIDGE module
    14391447
  • trunk/source/objc-bridge/objc-clos.lisp

    r14202 r14263  
    746746            (setq max loc)))))))
    747747
     748
     749(defun ensure-lisp-slots (instance class)
     750  (unless (%null-ptr-p instance)
     751    (or (gethash instance *objc-object-slot-vectors*)
     752        (let* ((slot-vector (create-foreign-instance-slot-vector class)))
     753          (when slot-vector
     754            (setf (slot-vector.instance slot-vector) instance)
     755            (setf (gethash instance *objc-object-slot-vectors*) slot-vector)))))
     756  instance)
    748757               
    749                                          
    750758(defmethod allocate-instance ((class objc:objc-class) &rest initargs &key &allow-other-keys)
    751759  (unless (class-finalized-p class)
    752760    (finalize-inheritance class))
    753   (let* ((instance
    754           (multiple-value-bind (ks vs) (keys-and-vals (remove-slot-initargs
    755                                                        class
    756                                                        initargs))
    757             (send-objc-init-message (allocate-objc-object class) ks vs))))
    758     (unless (%null-ptr-p instance)
    759       (or (gethash instance *objc-object-slot-vectors*)
    760           (let* ((slot-vector (create-foreign-instance-slot-vector class)))
    761             (when slot-vector
    762               (setf (slot-vector.instance slot-vector) instance)
    763               (setf (gethash instance *objc-object-slot-vectors*) slot-vector)))))
    764     instance))
    765 
    766 
     761  (send-init-message-for-class class initargs))
    767762
    768763
  • trunk/source/objc-bridge/objc-package.lisp

    r14203 r14263  
    4545           "OBJC-MESSAGE-SEND-SUPER" "OBJC-MESSAGE-SEND-SUPER-STRET"
    4646           "LOAD-FRAMEWORK" "*OBJC-DESCRIPTION-MAX-LENGTH*"
    47            "REMOVE-LISP-SLOTS"
     47           "REMOVE-LISP-SLOTS" "WITH-AUTORELEASE-POOL"
     48           "MAKE-NSSTRING" "LISP-STRING-FROM-NSSTRING"
     49           "WITH-AUTORELEASED-NSSTRINGS"
    4850           ))
    4951
     
    5658            objc:objc-message-send objc:objc-message-send-stret
    5759            objc:objc-message-send-super objc:objc-message-send-super-stret
    58             objc:*objc-description-max-length*)
     60            objc:*objc-description-max-length* objc:with-autorelease-pool
     61            objc:lisp-string-from-nsstring objc:with-autoreleased-nsstrings)
    5962          "CCL"))
    6063
  • trunk/source/objc-bridge/objc-runtime.lisp

    r14203 r14263  
    24942494
    24952495
     2496
     2497
     2498                           
     2499   
     2500                   
     2501
    24962502;;; Call get-objc-message-info for all known init messages.  (A
    24972503;;; message is an "init message" if it starts with the string "init",
     
    25032509                                      #'(lambda (string)
    25042510                                          (string= string "init" :end1 (min (length string) 4)))))
    2505       (get-objc-message-info init))))
     2511      (process-init-message (get-objc-message-info init)))))
    25062512
    25072513   
  • 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.