Changeset 12455

Timestamp:

Jul 26, 2009, 9:49:18 AM (10 years ago)

Author:

gb

Message:

In (SETF CLASS-DIRECT-SLOTS) :BEFORE method on OBJC:OBJC-CLASS:
check that #_class_addIvar succeeds to avoid obscure errors that
occur if it doesn't (it's not yet implemented in Cocotron.)

File:

• trunk/source/objc-bridge/objc-clos.lisp (modified) (4 diffs)

trunk/source/objc-bridge/objc-clos.lisp

@@ -423 +423 @@
         (with-cstrs ((name string)
                      (encoding encoding))
-          (#_class_addIvar class name size align encoding)
+          (when (eql #$NO (#_class_addIvar class name size align encoding))
+            (error "class_addIvar failed"))
           (with-macptrs ((ivar (#_class_getInstanceVariable class name)))
-              (unless (%null-ptr-p ivar)
-                (let* ((offset (#_ivar_getOffset ivar)))
-                  (setf (foreign-direct-slot-definition-bit-offset dslotd)
-                        (ash offset 3))))))))))
+            (unless (%null-ptr-p ivar)
+              (let* ((offset (#_ivar_getOffset ivar)))
+                (setf (foreign-direct-slot-definition-bit-offset dslotd)
+                      (ash offset 3))))))))))
 
 
@@ -458 +459 @@
 ;;; each foreign direct slotd's offset field should already have been
 ;;; set to the slot's bit offset.
-#-apple-objc-2.0
+#-(or apple-objc-2.0 cocotron-objc)
 (defun %make-objc-ivars (class)
   (let* ((start-offset (superclass-instance-size class))
@@ -544 +545 @@
               (signed (foreign-integer-type-signed ftype)))
          (if (= bits align)
-           (ecase bits
+           (case bits
              (1 (values #'%get-bit #'%set-bit))
              (8 (values (if signed #'%get-signed-byte #'%get-unsigned-byte)
@@ -554 +555 @@
              (64 (if signed
                    (values #'%%get-signed-longlong #'%%set-signed-longlong)
-                   (values #'%%get-unsigned-longlong #'%%set-unsigned-longlong))))
+                   (values #'%%get-unsigned-longlong #'%%set-unsigned-longlong)))
+             (t (values #'(lambda (ptr offset)
+                       (%get-bitfield ptr offset bits))
+                   #'(lambda (ptr offset new)
+                       (setf (%get-bitfield ptr offset bits) new)))))
            (values #'(lambda (ptr offset)
                        (%get-bitfield ptr offset bits))