Index: /trunk/ccl/examples/objc-clos.lisp
===================================================================
--- /trunk/ccl/examples/objc-clos.lisp	(revision 449)
+++ /trunk/ccl/examples/objc-clos.lisp	(revision 450)
@@ -47,4 +47,6 @@
 (package-force-export "NS")
 
+(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.")
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;;                                 Testing                                ;;;;
@@ -80,4 +82,22 @@
 
 (defvar *objc-object-slot-vectors* (make-hash-table :test #'eql))
+(defvar *objc-canonical-instances* (make-hash-table :test #'eql :weak :value))
+
+(defun raw-macptr-for-instance (instance)
+  (let* ((p (%null-ptr)))
+    (%set-macptr-domain p 1)		; not an ObjC object, but EQL to one
+    (%setf-macptr p instance)
+    p))
+
+(defun register-canonical-objc-instance (instance raw-ptr)
+  ;(terminate-when-unreachable instance)
+  ;(retain-objc-instance instance)
+  (setf (gethash raw-ptr *objc-canonical-instances*) instance))
+
+(defun canonicalize-objc-instance (instance)
+  (or (gethash instance *objc-canonical-instances*)
+      (register-canonical-objc-instance
+       (setq instance (%inc-ptr instance 0))
+       (raw-macptr-for-instance instance))))
 
 (defun recognize-objc-object (p)
@@ -97,5 +117,5 @@
     (ecase flags
       (#.objc-flag-instance (id->objc-class index))
-      (#.objc-flag-class (id->objc-metaclass index))
+      (#.objc-flag-class (objc-class-id->objc-metaclass index))
       (#.objc-flag-metaclass *objc-metaclass-class*))))
   
@@ -113,5 +133,5 @@
     (ecase flags
       (#.objc-flag-instance (id->objc-class-wrapper index))
-      (#.objc-flag-class (id->objc-metaclass-wrapper index))
+      (#.objc-flag-class (id->objc-metaclass-wrapper (objc-class-id->objc-metaclass-id index)))
       (#.objc-flag-metaclass (%class.own-wrapper *objc-metaclass-class*)))))
 
@@ -197,5 +217,9 @@
 (defmethod print-object ((o objc:objc-object) stream)
   (print-unreadable-object (o stream :type t)
-    (format stream "~a (#x~x)" (nsobject-description o) (%ptr-to-int o))))
+    (format stream
+	    (if (typep o 'ns::ns-string)
+	      "~s (#x~x)"
+	      "~a (#x~x)")
+	    (nsobject-description o) (%ptr-to-int o))))
 
 
@@ -301,27 +325,34 @@
     (with-macptrs ((ivars (pref c :objc_class.ivars)))
       (unless (%null-ptr-p ivars)
-	(loop with ns-package = (find-package "NS")
-	      with n = (pref ivars :objc_ivar_list.ivar_count)
-	      with state = (make-ivar-parse-state c)
-	      for i from 1 to n
-	      for ivar = (pref ivars :objc_ivar_list.ivar_list) 
-	          then (%inc-ptr ivar (record-length :objc_ivar))
-	      for name = (%get-cstring (pref ivar :objc_ivar.ivar_name))
-	      for sym = (compute-lisp-name name ns-package)
-	      when (eql (schar name 0) #\_)
-	        do (unexport sym ns-package)
-	      ;do (format t "~S: ~S~%" name (pref ivar :objc_ivar.ivar_offset))
-	      collect 
-	      (make-direct-slot-definition-from-ivar
-	       state
-	       (pref ivar :objc_ivar.ivar_offset)
-	       (with-string-from-cstring
-			  (s (pref ivar :objc_ivar.ivar_type))
-			(objc-foreign-type-for-ivar s))
-	       c
-	       (list
-		:name sym
-		:allocation :instance
-		:class c )))))))
+	(let* ((ns-package (find-package "NS"))
+	       (n (pref ivars :objc_ivar_list.ivar_count))
+	       (state (make-ivar-parse-state c)))
+	  (collect ((dslotds))
+	    (do* ((i 0 (1+ i))
+		  (ivar (pref ivars :objc_ivar_list.ivar_list)
+			(%inc-ptr ivar (record-length :objc_ivar))))
+		 ((= i n) (dslotds))
+	      (declare (fixnum i))
+	      (with-macptrs ((nameptr (pref ivar :objc_ivar.ivar_name)))
+		(let* ((is-private (eql (%get-unsigned-byte nameptr 0)
+				    (char-code #\_))))
+		  (when (or (not is-private)
+			    *objc-import-private-ivars*)
+		    (let* ((name (%get-cstring nameptr))
+			   (sym (compute-lisp-name name ns-package)))
+		      (when is-private
+			(unexport sym ns-package))
+		      (dslotds
+		       (make-direct-slot-definition-from-ivar
+			state
+			(pref ivar :objc_ivar.ivar_offset)
+			(with-string-from-cstring
+			    (s (pref ivar :objc_ivar.ivar_type))
+			  (objc-foreign-type-for-ivar s))
+			c
+			(list
+			 :name sym
+			 :allocation :instance
+			 :class c ))))))))))))))
 
 (defun make-direct-slot-definition-from-ivar (state
@@ -493,5 +524,32 @@
        (values #'%get-single-float #'%set-single-float))
       (foreign-pointer-type
-       (values #'%get-ptr #'%set-ptr))
+       ;; If we're pointing to a structure whose first field is
+       ;; a pointer to a structure named :OBJC_CLASS, we're of
+       ;; type :ID and can (fairly) safely use %GET-PTR.
+       ;; Otherwise, reference the field as a raw  macptr.
+       (let* ((to (foreign-pointer-type-to ftype)))
+	 (if
+	   (and (typep to 'foreign-record-type)
+		(eq :struct (foreign-record-type-kind to))
+		(progn
+		  (ensure-foreign-type-bits to)
+		  (let* ((first-field (car (foreign-record-type-fields to)))
+			 (first-field-type
+			  (if first-field
+			    (foreign-record-field-type first-field))))
+		    (and (typep first-field-type 'foreign-pointer-type)
+			 (let* ((first-to (foreign-pointer-type-to
+					   first-field-type)))
+			   (and (typep first-to 'foreign-record-type)
+				(eq :struct
+				    (foreign-record-type-kind first-to))
+				(eq :objc_class
+				    (foreign-record-type-name first-to))))))))
+	   (values #'%get-ptr #'%set-ptr)
+	   (values #'(lambda (ptr offset)
+		       (let* ((p (%null-ptr)))
+			 (%set-macptr-domain p 1)
+			 (%setf-macptr p (%get-ptr ptr offset))))
+		   #'%set-ptr))))
       (foreign-mem-block-type
        (let* ((nbytes (%foreign-type-or-record-size ftype :bytes)))
@@ -661,12 +719,10 @@
     (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) instance)
-	(setf (gethash instance *objc-object-slot-vectors*) slot-vector)
-	(terminate-when-unreachable instance)
-	(retain-obcj-object instance)
-	instance))))
+	(setf (slot-vector.instance slot-vector) raw-ptr)
+	(register-canonical-objc-instance instance raw-ptr)))))
 
 (defmethod terminate ((instance objc:objc-object))
Index: /trunk/ccl/examples/objc-runtime.lisp
===================================================================
--- /trunk/ccl/examples/objc-runtime.lisp	(revision 449)
+++ /trunk/ccl/examples/objc-runtime.lisp	(revision 450)
@@ -68,6 +68,4 @@
 
 
-;			 (let* ((metaclass-name (intern (concatenate 'string "+" (string class-name)) (symbol-package class-name)))
-
 
 (let* ((objc-class-map (make-splay-tree #'%ptr-eql
@@ -85,4 +83,5 @@
        (objc-class-lock (make-lock))
        (next-objc-class-id 0)
+       (next-objc-metaclass-id 0)
        (class-table-size 1024)
        (c (make-array 1024))
@@ -91,13 +90,12 @@
        (mw (make-array 1024 :initial-element nil))
        (csv (make-array 1024))
-       (msv (make-array 1024)))
-
-  (flet ((assign-next-class-id ()
-           (let* ((id next-objc-class-id))
-             (if (= (incf next-objc-class-id) class-table-size)
-               (let* ((old-size class-table-size)
-                      (new-size (* 2 class-table-size)))
-                 (declare (fixnum old-size new-size))
-                 (macrolet ((extend (v)
+       (msv (make-array 1024))
+       (class-id->metaclass-id (make-array 1024 :initial-element nil)))
+
+  (flet ((grow-vectors ()
+	   (let* ((old-size class-table-size)
+		  (new-size (* 2 old-size)))
+	     (declare (fixnum old-size new-size))
+	     (macrolet ((extend (v)
                               `(setq ,v (%extend-vector old-size ,v new-size))))
                    (extend c)
@@ -105,73 +103,96 @@
                    (extend cw)
                    (extend mw)
+		   (fill cw nil :start old-size :end new-size)
+		   (fill mw nil :start old-size :end new-size)
                    (extend csv)
-                   (extend msv))
-                 (setq class-table-size new-size)))
-             id)))
-    (defun id->objc-class (i)
-      (svref c i))
-    (defun (setf id->objc-class) (new i)
-      (setf (svref c i) new))
-    (defun id->objc-metaclass (i)
-      (svref m i))
-    (defun (setf id->objc-metaclass) (new i)
-      (setf (svref m i) new))
-    (defun id->objc-class-wrapper (i)
-      (svref cw i))
-    (defun (setf id->objc-class-wrapper) (new i)
-      (setf (svref cw i) new))
-    (defun id->objc-metaclass-wrapper (i)
-      (svref mw i))
-    (defun (setf id->objc-metaclass-wrapper) (new i)
-      (setf (svref mw i) new))
-    (defun id->objc-class-slots-vector (i)
-      (svref csv i))
-    (defun (setf id->objc-class-slots-vector) (new i)
-      (setf (svref csv i) new))
-    (defun id->objc-metaclass-slots-vector (i)
-      (svref msv i))
-    (defun (setf id->objc-metaclass-slots-vector) (new i)
-      (setf (svref msv i) new))
-    
-    (defun %clear-objc-class-maps ()
-      (with-lock-grabbed (objc-class-lock)
-        (fill c 0)
-        (fill m 0)
-        (fill cw 0)
-        (fill mw 0)
-        (fill csv 0)
-        (fill msv 0)
-        (setf (splay-tree-root objc-class-map) nil
-              (splay-tree-root objc-metaclass-map) nil
-              (splay-tree-count objc-class-map) 0
-              (splay-tree-count objc-metaclass-map) 0
-              next-objc-class-id 0)))
-
-    (defun register-objc-class (class)
-      "ensure that the class (and metaclass) are mapped to a small integer,
-and that each have slots-vectors associated with them."
-      (with-lock-grabbed (objc-class-lock)
-	(ensure-objc-classptr-resolved class)
-	(or (splay-tree-get objc-class-map class)
-	    (let* ((id (assign-next-class-id))
-		   (class (%inc-ptr class 0))
-		   (meta (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer)))
-	      (splay-tree-put objc-class-map class id)
-	      (splay-tree-put objc-metaclass-map meta id)
-	      (setf (svref c id) class
-		    (svref m id) meta
-		    (svref csv id)
-		    (make-objc-class-slots-vector class)
-		    (svref msv id)
-		    (make-objc-metaclass-slots-vector meta))
-	      id))))
-    (defun objc-class-id (class)
-      (with-lock-grabbed (objc-class-lock)
-        (splay-tree-get objc-class-map class)))
-    (defun objc-metaclass-id (meta)
-      (with-lock-grabbed (objc-class-lock)
-        (splay-tree-get objc-metaclass-map meta)))
-    (defun objc-class-map () objc-class-map)
-    (defun objc-metaclass-map () objc-metaclass-map)))
+                   (extend msv)
+		   (extend class-id->metaclass-id)
+		   (fill class-id->metaclass-id nil :start old-size :end new-size))
+	     (setq class-table-size new-size))))
+    (flet ((assign-next-class-id ()
+	     (let* ((id next-objc-class-id))
+	       (if (= (incf next-objc-class-id) class-table-size)
+		 (grow-vectors))
+	       id))
+	   (assign-next-metaclass-id ()
+	     (let* ((id next-objc-metaclass-id))
+	       (if (= (incf next-objc-metaclass-id) class-table-size)
+		 (grow-vectors))
+	       id)))
+      (defun id->objc-class (i)
+	(svref c i))
+      (defun (setf id->objc-class) (new i)
+	(setf (svref c i) new))
+      (defun id->objc-metaclass (i)
+	(svref m i))
+      (defun (setf id->objc-metaclass) (new i)
+	(setf (svref m i) new))
+      (defun id->objc-class-wrapper (i)
+	(svref cw i))
+      (defun (setf id->objc-class-wrapper) (new i)
+	(setf (svref cw i) new))
+      (defun id->objc-metaclass-wrapper (i)
+	(svref mw i))
+      (defun (setf id->objc-metaclass-wrapper) (new i)
+	(setf (svref mw i) new))
+      (defun id->objc-class-slots-vector (i)
+	(svref csv i))
+      (defun (setf id->objc-class-slots-vector) (new i)
+	(setf (svref csv i) new))
+      (defun id->objc-metaclass-slots-vector (i)
+	(svref msv i))
+      (defun (setf id->objc-metaclass-slots-vector) (new i)
+	(setf (svref msv i) new))
+      (defun %clear-objc-class-maps ()
+	(with-lock-grabbed (objc-class-lock)
+	  (fill c 0)
+	  (fill m 0)
+	  (fill cw nil)
+	  (fill mw nil)
+	  (fill csv 0)
+	  (fill msv 0)
+	  (fill class-id->metaclass-id nil)
+	  (setf (splay-tree-root objc-class-map) nil
+		(splay-tree-root objc-metaclass-map) nil
+		(splay-tree-count objc-class-map) 0
+		(splay-tree-count objc-metaclass-map) 0
+		next-objc-class-id 0
+		next-objc-metaclass-id 0)))
+      (flet ((install-objc-metaclass (meta)
+	       (or (splay-tree-get objc-metaclass-map meta)
+		   (let* ((id (assign-next-metaclass-id))
+			  (meta (%inc-ptr meta 0)))
+		     (splay-tree-put objc-metaclass-map meta id)
+		     (setf (svref m id) meta
+			   (svref msv id)
+			   (make-objc-metaclass-slots-vector meta))
+		     id))))
+	(defun register-objc-class (class)
+	  "ensure that the class is mapped to a small integer and associate a slots-vector with it."
+	  (with-lock-grabbed (objc-class-lock)
+	    (ensure-objc-classptr-resolved class)
+	    (or (splay-tree-get objc-class-map class)
+		(let* ((id (assign-next-class-id))
+		       (class (%inc-ptr class 0))
+		       (meta (pref class #+apple-objc :objc_class.isa #+gnu-objc :objc_class.class_pointer)))
+		  (splay-tree-put objc-class-map class id)
+		  (setf (svref c id) class
+			(svref csv id)
+			(make-objc-class-slots-vector class)
+			(svref class-id->metaclass-id id)
+			(install-objc-metaclass meta))
+		  id)))))
+      (defun objc-class-id (class)
+	(with-lock-grabbed (objc-class-lock)
+	  (splay-tree-get objc-class-map class)))
+      (defun objc-metaclass-id (meta)
+	(with-lock-grabbed (objc-class-lock)
+	  (splay-tree-get objc-metaclass-map meta)))
+      (defun objc-class-id->objc-metaclass-id (class-id)
+	(svref class-id->metaclass-id class-id))
+      (defun objc-class-id->objc-metaclass (class-id)
+	(svref m (svref class-id->metaclass-id class-id)))
+      (defun objc-class-map () objc-class-map)
+      (defun objc-metaclass-map () objc-metaclass-map))))
 
 (pushnew #'%clear-objc-class-maps *save-exit-functions* :test #'eq
@@ -235,4 +256,31 @@
 (pushnew 'remap-all-library-classes *lisp-system-pointer-functions*)
 
+(let* ((cfstring-sections (cons 0 nil)))
+  (defun reset-cfstring-sections ()
+    (rplaca cfstring-sections 0)
+    (rplacd cfstring-sections nil))
+  (defun find-cfstring-sections ()
+    (let* ((image-count (#_ _dyld_image_count)))
+      (when (> image-count (car cfstring-sections))
+	(process-section-in-all-libraries
+	 #$SEG_DATA
+	 "__cfstring"
+	 #'(lambda (sectaddr size)
+	     (let* ((addr (%ptr-to-int sectaddr))
+		    (limit (+ addr size))
+		    (already (member addr (cdr cfstring-sections) :key #'car)))
+	       (if already
+		 (rplacd already limit)
+		 (push (cons addr limit) (cdr cfstring-sections))))))
+	(setf (car cfstring-sections) image-count))))
+  (defun pointer-in-cfstring-section-p (ptr)
+    (let* ((addr (%ptr-to-int ptr)))
+      (dolist (s (cdr cfstring-sections))
+	(when (and (>= addr (car s))
+		   (< addr (cdr s)))
+	  (return t))))))
+	       
+					  
+
 )
 
@@ -298,29 +346,37 @@
 					 (pref class :objc_class.name))
 					"NS"))
-	       (meta (id->objc-metaclass id))
-	       (meta-name (intern (concatenate 'string
-					       "+"
-					       (string class-name))
-				  "NS"))
-	       (meta-super (pref meta :objc_class.super_class)))
-	  ;; It's important (here and when initializing the class
-	  ;; below) to use the "canonical" (registered) version
-	  ;; of the class, since some things in CLOS assume
-	  ;; EQness.  We probably don't want to violate that
-	  ;; assumption; it'll be easier to revive a saved image
-	  ;; if we don't have a lot of EQL-but-not-EQ class pointers
-	  ;; to deal with.
-	  (initialize-instance meta
-			       :name meta-name
-			       :direct-superclasses
-			       (list
-				(if (or (%null-ptr-p meta-super)
-					(not (%objc-metaclass-p meta-super)))
-				  (find-class 'objc:objc-class)
-				  (canonicalize-registered-metaclass meta-super)))
-			       :peer class
-			       :foreign t)
-	  (setf (find-class meta-name) meta)
-;	  (setf (id->objc-metaclass-wrapper id) (%class-own-wrapper meta))
+	       (meta-id (objc-class-id->objc-metaclass-id id)) 
+	       (meta (id->objc-metaclass meta-id)))
+	  ;; Metaclass may already be initialized.  It'll have a class
+	  ;; wrapper if so.
+	  (unless (id->objc-metaclass-wrapper meta-id)
+	    (let* ((meta-name (intern
+			       (concatenate 'string
+					    "+"
+					    (string
+					     (objc-to-lisp-classname
+					      (%get-cstring
+					       (pref meta :objc_class.name))
+					      "NS")))
+				      "NS"))
+		   (meta-super (pref meta :objc_class.super_class)))
+	      ;; It's important (here and when initializing the class
+	      ;; below) to use the "canonical" (registered) version
+	      ;; of the class, since some things in CLOS assume
+	      ;; EQness.  We probably don't want to violate that
+	      ;; assumption; it'll be easier to revive a saved image
+	      ;; if we don't have a lot of EQL-but-not-EQ class pointers
+	      ;; to deal with.
+	      (initialize-instance meta
+				   :name meta-name
+				   :direct-superclasses
+				   (list
+				    (if (or (%null-ptr-p meta-super)
+					    (not (%objc-metaclass-p meta-super)))
+				      (find-class 'objc:objc-class)
+				      (canonicalize-registered-metaclass meta-super)))
+				   :peer class
+				   :foreign t)
+	      (setf (find-class meta-name) meta)))
 	  (setf (slot-value class 'direct-slots)
 		(%compute-foreign-direct-slots class))
@@ -334,5 +390,4 @@
 			       :peer meta
 			       :foreign t)
-;	  (setf (id->objc-class-wrapper id) (%class-own-wrapper class))
 	  (setf (find-class class-name) class))))))
 				
@@ -919,4 +974,8 @@
 	   #+gnu-objc #$_CLS_META))
 	   
+(defun %objc-class-posing-p (class)
+  (logtest (pref class :objc_class.info)
+	   #+apple-objc #$CLS_POSING
+	   #+gnu-objc #$_CLS_POSING))
 
 
@@ -942,5 +1001,5 @@
 		 (%null-ptr)
 		 0)))
-	   (meta (id->objc-metaclass id))
+	   (meta (objc-class-id->objc-metaclass id))
 	   (class (id->objc-class id))
 	   (meta-name (intern (format nil "+~a" class-name)
@@ -951,6 +1010,5 @@
 			 :name meta-name
 			 :direct-superclasses (list meta-super))
-    (setf ;(id->objc-metaclass-wrapper id) (%class-own-wrapper meta)
-	  (find-class meta-name) meta)
+      (setf (find-class meta-name) meta)
     class)))
 
@@ -1029,17 +1087,13 @@
 (defun %objc-instance-class-index (p)
   #+apple-objc
-  (let* ((instance-apparent-size (zone-pointer-size p)))
-    (when (and instance-apparent-size (not (eql instance-apparent-size 0)))
-      (locally (declare (fixnum instance-apparent-size))
-	  (with-macptrs ((parent (pref p :objc_object.isa)))
-	    (let* ((idx (objc-class-id parent)))
-	      (when idx
-		(let* ((parent-size (if idx (pref parent :objc_class.instance_size))))
-		  (if (eql (- (ash (ash (the fixnum (+ parent-size 17)) -4) 4) 2)
-			   instance-apparent-size)
-		    idx)))))))))
+  (if (or (pointer-in-cfstring-section-p p)
+	  (with-macptrs ((zone (#_malloc_zone_from_ptr p)))
+	    (not (%null-ptr-p zone))))
+    (with-macptrs ((parent (pref p :objc_object.isa)))
+      (objc-class-id parent)))
   #+gnu-objc
   (with-macptrs ((parent (pref p objc_object.class_pointer)))
     (objc-class-id-parent))
+  )
 
 ;;; If an instance, return (values :INSTANCE <class>).
@@ -1365,4 +1419,5 @@
     (free obj)))
 
+#+threads-problem
 (def-ccl-pointers install-deallocate-hook ()
   (setf (%get-ptr (foreign-symbol-address "__dealloc")) deallocate-nsobject))
@@ -1393,4 +1448,7 @@
 ")
 
+
+(defun retain-objc-instance (instance)
+  (objc-message-send instance "retain"))
 
 ;;; Execute BODY with an autorelease pool