Index: /trunk/ccl/examples/objc-runtime.lisp
===================================================================
--- /trunk/ccl/examples/objc-runtime.lisp	(revision 485)
+++ /trunk/ccl/examples/objc-runtime.lisp	(revision 486)
@@ -91,5 +91,8 @@
        (csv (make-array 1024))
        (msv (make-array 1024))
-       (class-id->metaclass-id (make-array 1024 :initial-element nil)))
+       (class-id->metaclass-id (make-array 1024 :initial-element nil))
+       (class-foreign-names (make-array 1024))
+       (metaclass-foreign-names (make-array 1024))
+       )
 
   (flet ((grow-vectors ()
@@ -108,5 +111,7 @@
                    (extend msv)
 		   (extend class-id->metaclass-id)
-		   (fill class-id->metaclass-id nil :start old-size :end new-size))
+		   (fill class-id->metaclass-id nil :start old-size :end new-size)
+		   (extend class-foreign-names)
+		   (extend metaclass-foreign-names))
 	     (setq class-table-size new-size))))
     (flet ((assign-next-class-id ()
@@ -144,19 +149,18 @@
       (defun (setf id->objc-metaclass-slots-vector) (new i)
 	(setf (svref msv i) new))
+      (defun objc-class-id-foreign-name (i)
+	(svref class-foreign-names i))
+      (defun (setf objc-class-id-foreign-name) (new i)
+	(setf (svref class-foreign-names i) new))
+      (defun objc-metaclass-id-foreign-name (i)
+	(svref metaclass-foreign-names i))
+      (defun (setf objc-metaclass-id-foreign-name) (new i)
+	(setf (svref metaclass-foreign-names 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)))
+		(splay-tree-count objc-metaclass-map) 0)))
       (flet ((install-objc-metaclass (meta)
 	       (or (splay-tree-get objc-metaclass-map meta)
@@ -194,5 +198,7 @@
 	(svref m (svref class-id->metaclass-id class-id)))
       (defun objc-class-map () objc-class-map)
-      (defun objc-metaclass-map () objc-metaclass-map))))
+      (defun %objc-class-count () next-objc-class-id)
+      (defun objc-metaclass-map () objc-metaclass-map)
+      (defun %objc-metaclass-count () next-objc-metaclass-id))))
 
 (pushnew #'%clear-objc-class-maps *save-exit-functions* :test #'eq
@@ -214,5 +220,5 @@
       (id->objc-metaclass id)
       (error "Class ~S isn't recognized." m))))
-  
+
 
 ;;; Open shared libs.
@@ -254,5 +260,4 @@
                  t))))))
 
-(pushnew 'remap-all-library-classes *lisp-system-pointer-functions*)
 
 (let* ((cfstring-sections (cons 0 nil)))
@@ -333,4 +338,73 @@
 
 
+;;; When starting up an image that's had ObjC classes in it, all of
+;;; those canonical classes (and metaclasses) will have had their type
+;;; changed (by SAVE-APPLICATION) to, CCL::DEAD-MACPTR and the addresses
+;;; of those classes may be bogus.  The splay trees (objc-class/metaclass-map)
+;;; should be empty.
+;;; For each class that -had- had an assigned ID, determine its ObjC
+;;; class name, and ask ObjC where (if anywhere) the class is now.
+;;; If we get a non-null answer, revive the class pointer and set its
+;;; address appropriately, then add an entry to the splay tree; this
+;;; means that classes that existed on both sides of SAVE-APPLICATION
+;;; will retain the same ID.
+
+(defun revive-objc-classes ()
+  ;; Make a first pass over the class and metaclass tables;
+  ;; resolving those foreign classes that existed in the old
+  ;; image and still exist in the new.
+  (let* ((class-map (objc-class-map))
+	 (metaclass-map (objc-metaclass-map))
+	 (nclasses (%objc-class-count)))
+    (dotimes (i nclasses)
+      (let* ((c (id->objc-class i))
+	     (meta-id (objc-class-id->objc-metaclass-id i))
+	     (m (id->objc-metaclass meta-id)))
+	(%revive-macptr c)
+	(%revive-macptr m)
+	(unless (splay-tree-get class-map c)
+	  (%set-pointer-to-objc-class-address (objc-class-id-foreign-name i) c)
+	  ;; If the class is valid and the metaclass is still a
+	  ;; dead pointer, revive the metaclass 
+	  (unless (%null-ptr-p c)
+	    (splay-tree-put class-map c i)
+	    (unless (splay-tree-get metaclass-map m)
+	      (when (%null-ptr-p m)
+		(%setf-macptr m (pref c #+apple-objc :objc_class.isa
+				      #+gnu-objc :objc_class.class_pointer)))
+	      (splay-tree-put metaclass-map m meta-id))))))
+    (break "second pass")
+    ;; Second pass: install class objects for user-defined classes,
+    ;; assuming the superclasses are already "revived".
+    (dotimes (i nclasses)
+      (let* ((c (id->objc-class i)))
+	(when (and (%null-ptr-p c)
+		   (not (slot-value c 'foreign)))
+	  (let* ((super (dolist (s (class-direct-superclasses c)
+				 (error "No ObjC superclass of ~s" c))
+			  (when (objc-class-p s) (return s))))
+		 (meta-id (objc-class-id->objc-metaclass-id i))
+		 (m (id->objc-metaclass meta-id)))
+	    (when (%null-ptr-p m)
+	      (%setf-macptr m (%make-basic-meta-class
+			       (objc-metaclass-id-foreign-name meta-id)
+			       super
+			       (@class "NSObject")))
+	      (splay-tree-put metaclass-map m meta-id))
+	    (%setf-macptr c (%make-class-object
+			     m
+			     super
+			     (objc-class-id-foreign-name i)
+			     (%null-ptr)
+			     0))
+	    (multiple-value-bind (ivars instance-size)
+		(%make-objc-ivars c)
+	      (%add-objc-class c ivars instance-size)
+	      (splay-tree-put class-map c i))))))))
+      
+      
+    
+    
+
 (defun install-foreign-objc-class (class)
   (let* ((id (objc-class-id class)))
@@ -342,7 +416,8 @@
 	(unless (%null-ptr-p super)
 	  (install-foreign-objc-class super))
-	(let* ((class-name 
-		(objc-to-lisp-classname (%get-cstring
-					 (pref class :objc_class.name))
+	(let* ((class-foreign-name (%get-cstring
+					 (pref class :objc_class.name)))
+	       (class-name 
+		(objc-to-lisp-classname class-foreign-name
 					"NS"))
 	       (meta-id (objc-class-id->objc-metaclass-id id)) 
@@ -351,11 +426,12 @@
 	  ;; wrapper if so.
 	  (unless (id->objc-metaclass-wrapper meta-id)
-	    (let* ((meta-name (intern
+	    (let* ((meta-foreign-name (%get-cstring
+				       (pref meta :objc_class.name)))
+		   (meta-name (intern
 			       (concatenate 'string
 					    "+"
 					    (string
 					     (objc-to-lisp-classname
-					      (%get-cstring
-					       (pref meta :objc_class.name))
+					      meta-foreign-name
 					      "NS")))
 				      "NS"))
@@ -378,4 +454,6 @@
 				   :peer class
 				   :foreign t)
+	      (setf (objc-metaclass-id-foreign-name meta-id)
+		    meta-foreign-name)
 	      (setf (find-class meta-name) meta)))
 	  (setf (slot-value class 'direct-slots)
@@ -390,4 +468,5 @@
 			       :peer meta
 			       :foreign t)
+	  (setf (objc-class-id-foreign-name id) class-foreign-name)
 	  (setf (find-class class-name) class))))))
 				
@@ -508,4 +587,14 @@
 	  (error "ObjC class ~a not found" name))
 	p))))
+
+(defun %set-pointer-to-objc-class-address (class-name-string ptr)
+  (with-cstrs ((cstr class-name-string))
+    (%setf-macptr ptr
+		  (#+apple-objc #_objc_lookUpClass
+		   #+gnu-objc #_objc_lookup_class
+		   cstr)))
+  nil)
+   
+		  
 
 (defvar *objc-class-descriptors* (make-hash-table :test #'equal))
@@ -1001,5 +1090,6 @@
 		 (%null-ptr)
 		 0)))
-	   (meta (objc-class-id->objc-metaclass id))
+	   (meta-id (objc-class-id->objc-metaclass-id id))
+	   (meta (id->objc-metaclass meta-id))
 	   (class (id->objc-class id))
 	   (meta-name (intern (format nil "+~a" class-name)
@@ -1010,5 +1100,7 @@
 			 :name meta-name
 			 :direct-superclasses (list meta-super))
-      (setf (find-class meta-name) meta)
+      (setf (objc-class-id-foreign-name id) class-name
+	    (objc-metaclass-id-foreign-name meta-id) class-name
+	    (find-class meta-name) meta)
     class)))
 
@@ -1205,9 +1297,5 @@
      imp)))
 
-(def-ccl-pointers add-objc-methods ()
-  (maphash #'(lambda (impname m)
-	       (declare (ignore impname))
-	       (%add-lisp-objc-method m))
-	   *lisp-objc-methods*))
+
 
 (defun %define-lisp-objc-method (impname classname selname typestring imp
@@ -1410,13 +1498,25 @@
 #+apple-objc
 (progn
-(defcallback deallocate-nsobject (:address obj :void)
+(defloadvar *original-deallocate-hook*
+    (%get-ptr (foreign-symbol-address "__dealloc")))
+
+(defcallback deallocate-nsobject (:address obj :int)
   (unless (%null-ptr-p obj)
-    (remhash obj *objc-object-slot-vectors*)
-    (setf (pref obj :objc_object.isa)
-	  (external-call "__objc_getFreedObjectClass" :address))
-    (free obj)))
+    (remhash obj *objc-object-slot-vectors*))
+  (ff-call *original-deallocate-hook* :address obj :int))
+
+(defun install-lisp-deallocate-hook ()
+  (setf (%get-ptr (foreign-symbol-address "__dealloc")) deallocate-nsobject))
 
 (def-ccl-pointers install-deallocate-hook ()
-  (setf (%get-ptr (foreign-symbol-address "__dealloc")) deallocate-nsobject))
+  (install-lisp-deallocate-hook))
+
+(defun uninstall-lisp-deallocate-hook ()
+  (clrhash *objc-object-slot-vectors*)
+  (setf (%get-ptr (foreign-symbol-address "__dealloc")) *original-deallocate-hook*))
+
+#+testing
+(pushnew #'uninstall-lisp-deallocate-hook *lisp-cleanup-functions* :test #'eq
+         :key #'function-name)
 )