Changeset 543

Timestamp:

Feb 15, 2004, 8:22:13 AM (21 years ago)

Author:

Gary Byers

Message:

ALLOCATE-INSTANCE et al: install the instance's slot-vector if it has one.
Error out (don't just return nil) if instance slot-vector is missing.
Randall's fix to WRITER-METHOD-CLASS.

File:

• trunk/ccl/examples/objc-clos.lisp (modified) (4 diffs)

trunk/ccl/examples/objc-clos.lisp

@@ -148 +148 @@
     (declare (fixnum type flags index))
     (ecase flags
-      (#.objc-flag-instance (gethash p *objc-object-slot-vectors*))
+      (#.objc-flag-instance (or (gethash p *objc-object-slot-vectors*)
+                                (error "~s has no slots." p)))
       (#.objc-flag-class (id->objc-class-slots-vector index))
       (#.objc-flag-metaclass (id->objc-metaclass-slots-vector index)))))
@@ -703 +704 @@
             append (list (first l) (second l))  into new-initargs)))
 
+(defun create-foreign-instance-slot-vector (class)
+  (let* ((max 0))
+    (dolist (slotd (class-slots class)
+             (unless (zerop max)
+               (allocate-typed-vector :slot-vector (1+ max) (%slot-unbound-marker))))
+      (when (typep slotd 'standard-effective-slot-definition)
+        (let* ((loc (slot-definition-location slotd)))
+          (if (> loc max)
+            (setq max loc)))))))
+
+               
+                                         
 (defmethod allocate-instance ((class objc:objc-class) &rest initargs &key &allow-other-keys)
   (unless (class-finalized-p class)
@@ -713 +726 @@
             (apply #'%send (%send class 'alloc) (lisp-to-objc-init ks) vs))))
     (unless (%null-ptr-p instance)
-      (let* ((len (length (%wrapper-instance-slots (class-own-wrapper class))))
-             (raw-ptr (raw-macptr-for-instance instance)) 
-             (slot-vector
-              (unless (zerop len)
-                (allocate-typed-vector :slot-vector (1+ len) (%slot-unbound-marker)))))
-        (setf (slot-vector.instance slot-vector) raw-ptr)
+      (let* ((raw-ptr (raw-macptr-for-instance instance)) 
+             (slot-vector (create-foreign-instance-slot-vector class)))
+        (when slot-vector
+          (setf (slot-vector.instance slot-vector) raw-ptr)
+          (setf (gethash raw-ptr *objc-object-slot-vectors*) slot-vector))
         (register-canonical-objc-instance instance raw-ptr)))))
 
@@ -852 +864 @@
                                 &rest initargs)
   (declare (ignore initargs))
-  (find-class 'standard-reader-method))
+  (find-class 'standard-writer-method))