Changeset 468

Timestamp:

Feb 2, 2004, 8:22:47 AM (21 years ago)

Author:

Gary Byers

Message:

New OBJC-[CLASS,METACLASS,INSTANCE]-p, OBJC-OBJECT-P uses them.

Install a callback to take over _dealloc responsibilities. Doing so
seems to sometimes trigger a hang on QUIT, where the initial thread
never gets an interrupt. Maybe memory corruption, maybe something
else: need to check that (free) is the right way to free the object.

File:

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

trunk/ccl/examples/objc-runtime.lisp

@@ -1047 +1047 @@
 
 
-;;; If P is an ObjC class (or metaclass), return the class & metaclass,
-;;; else return (VALUES NIL NIL).
+;;; Return the "canonical" version of P iff it's a known ObjC class
 (defun objc-class-p (p)
   (if (typep p 'macptr)
-    (let* ((id (or (objc-class-id p) (objc-metaclass-id p))))
-      (if id
-        (values (id->objc-class id) (id->objc-metaclass id))
-        (values nil nil)))))
+    (let* ((id (objc-class-id p)))
+      (if id (id->objc-class id)))))
+
+;;; Return the canonical version of P iff it's a known ObjC metaclass
+(defun objc-metaclass-p (p)
+  (if (typep p 'macptr)
+    (let* ((id (objc-metaclass-id p)))
+      (if id (id->objc-metaclass id)))))
 
 ;;; If P is an ObjC instance, return a pointer to its class.
@@ -1060 +1063 @@
 ;;; ultimately malloc-based.
 (defun objc-instance-p (p)
-  (and (typep p 'macptr)
-       #+apple-objc
-       (not (%null-ptr-p (#_malloc_zone_from_ptr p)))
-       ;; #_malloc_zone_from_pointer seems pretty robust.
-       ;; If it returned a non-null "zone", it's probably safe
-       ;; to indirect through P.
-       (with-macptrs ((parent (pref p
-                                    #+apple-objc :objc_object.isa
-                                    #+gnu-objc :objc_object.class_pointer)))
-         (or (objc-class-p parent)
-             (values (objc-instance-p parent))))))
+  (when (typep p 'macptr)
+    (let* ((idx (%objc-instance-class-index p)))
+      (if idx (id->objc-class  idx)))))
 
 
@@ -1097 +1092 @@
   )
 
-;;; If an instance, return (values :INSTANCE <class>).
-;;; If a class, return (values :CLASS <metaclass>).
-;;; If a metaclass, return (values :METACLASS <class>).
+;;; If an instance, return (values :INSTANCE <class>)
+;;; If a class, return (values :CLASS <class>).
+;;; If a metaclass, return (values :METACLASS <metaclass>).
 ;;; Else return (values NIL NIL).
 (defun objc-object-p (p)
-  (multiple-value-bind (class metaclass) (objc-class-p p)
-    (if (eql p class)
-      (values :class metaclass)
-      (if (eql p metaclass)
-        (values :metaclass class)
-        (if (setq class (objc-instance-p p))
-          (values :instance class)
-          (values nil nil))))))
+  (let* ((instance-p (objc-instance-p p)))
+    (if instance-p
+      (values :instance instance-p)
+      (let* ((class-p (objc-class-p p)))
+        (if class-p
+          (values :class class-p)
+          (let* ((metaclass-p (objc-metaclass-p p)))
+            (if metaclass-p
+              (values :metaclass metaclass-p)
+              (values nil nil))))))))
+
        
 
@@ -1419 +1417 @@
     (free obj)))
 
-#+threads-problem
 (def-ccl-pointers install-deallocate-hook ()
   (setf (%get-ptr (foreign-symbol-address "__dealloc")) deallocate-nsobject))