Changeset 6226


Ignore:
Timestamp:
Apr 8, 2007, 4:23:53 PM (13 years ago)
Author:
gb
Message:

RECOGNIZE-OBJC-OBJECT: maybe try mapping classes if first try fails.
ALLOCATE-INSTANCE of objc-object: don't canonicalize instance if
no lisp slots (so MAKE-INSTANCE is about as lightweight as
MAKE-OBJC-INSTANCE.)

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/examples/objc-clos.lisp

    r5865 r6226  
    4141(require "BRIDGE")
    4242
    43 ;;; All class names and instance variable names are interned in the NS package
    44 ;;; Force all symbols interned in the NS package to be external
    45 
    46 (defpackage "NS"
    47   (:use))
    48 
    49 (package-force-export "NS")
    5043
    5144(defparameter *objc-import-private-ivars* t "When true, the CLASS-DIRECT-SLOTS of imported ObjC classes will contain slot definitions for instance variables whose name starts with an underscore.  Note that this may exacerbate compatibility problems.")
     
    127120       (raw-macptr-for-instance instance))))
    128121
     122
    129123(defun recognize-objc-object (p)
    130   (let* ((idx (objc-class-id p)))
    131     (if idx
    132       (%set-macptr-type p (dpb objc-flag-class objc-type-flags idx))
    133       (if (setq idx (objc-metaclass-id p))
    134         (%set-macptr-type p (dpb objc-flag-metaclass objc-type-flags idx))
    135         (if (setq idx (%objc-instance-class-index p))
    136           (%set-macptr-type p idx))))))
     124  (labels ((recognize (p mapped)
     125             (let* ((idx (objc-class-id p)))
     126               (if idx
     127                 (%set-macptr-type p (dpb objc-flag-class objc-type-flags idx))
     128                 (if (setq idx (objc-metaclass-id p))
     129                   (%set-macptr-type p (dpb objc-flag-metaclass objc-type-flags idx))
     130                   (if (setq idx (%objc-instance-class-index p))
     131                     (%set-macptr-type p idx)
     132                     (unless mapped
     133                       (if (maybe-map-objc-classes)
     134                         (recognize p t)))))))))
     135    (recognize p nil)))
    137136
    138137(defun release-canonical-nsobject (object)
     
    420419        (with-cstrs ((name string)
    421420                     (encoding encoding))
    422           (unless (eql #$NO (#_class_addIvar class name size align encoding))
    423             (with-macptrs ((ivar (#_class_getInstanceVariable class name)))
     421          (#_class_addIvar class name size align encoding)
     422          (with-macptrs ((ivar (#_class_getInstanceVariable class name)))
    424423              (unless (%null-ptr-p ivar)
    425424                (let* ((offset (#_ivar_getOffset ivar)))
    426425                  (setf (foreign-direct-slot-definition-bit-offset dslotd)
    427                         (ash offset 3)))))))))))
     426                        (ash offset 3))))))))))
    428427
    429428                                               
     
    749748            (send-objc-init-message (allocate-objc-object class) ks vs))))
    750749    (unless (%null-ptr-p instance)
    751       (let* ((raw-ptr (raw-macptr-for-instance instance))
    752              (slot-vector (create-foreign-instance-slot-vector class)))
     750      (let* ((slot-vector (create-foreign-instance-slot-vector class)))
    753751        (when slot-vector
    754           (setf (slot-vector.instance slot-vector) raw-ptr)
    755           (setf (gethash raw-ptr *objc-object-slot-vectors*) slot-vector))
    756         (register-canonical-objc-instance instance raw-ptr)))))
     752          (let* ((raw-ptr (raw-macptr-for-instance instance)))
     753            (setf (slot-vector.instance slot-vector) raw-ptr)
     754            (setf (gethash raw-ptr *objc-object-slot-vectors*) slot-vector)
     755            (register-canonical-objc-instance instance raw-ptr))))
     756      instance)))
    757757
    758758(defmethod terminate ((instance objc:objc-object))
Note: See TracChangeset for help on using the changeset viewer.