Index: /trunk/ccl/examples/objc-support.lisp
===================================================================
--- /trunk/ccl/examples/objc-support.lisp	(revision 431)
+++ /trunk/ccl/examples/objc-support.lisp	(revision 432)
@@ -5,4 +5,54 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (require "BRIDGE"))
+
+
+#+apple-objc
+(progn
+  (let* ((class-count 0))
+    (declare (fixnum class-count))
+    (defun reset-objc-class-count () (setq class-count 0))
+    (defun map-objc-classes ()
+      (let* ((n (#_objc_getClassList (%null-ptr) 0)))
+	(declare (fixnum n))
+	(if (> n class-count)
+	  (%stack-block ((buffer (the fixnum (ash n ppc32::word-shift))))
+	    (#_objc_getClassList buffer n)
+	  (do* ((i class-count (1+ i)))
+	       ((= i n (setq class-count i)))
+	    (declare (fixnum i))
+	    (install-foreign-objc-class
+	     (%get-ptr buffer (the fixnum  (ash i ppc32::word-shift))))))))))
+  (def-ccl-pointers revive-objc-classes ()
+    (reset-objc-class-count)
+    (map-objc-classes)))
+
+#+gnu-objc
+(defun iterate-over-class-methods (class method-function)
+  (do* ((mlist (pref class :objc_class.methods)
+	       (pref mlist :objc_method_list.method_next)))
+       ((%null-ptr-p mlist))
+    (do* ((n (pref mlist :objc_method_list.method_count))
+	  (i 0 (1+ i))
+	  (method (pref mlist :objc_method_list.method_list)
+		  (%incf-ptr method (record-length :objc_method))))
+	 ((= i n))
+      (declare (fixnum i n))
+      (funcall method-function method class))))
+
+#+gnu-objc
+(progn
+  (let* ((objc-class-count 0))
+    (defun reset-objc-class-count () (setq objc-class-count 0))
+    (defun note-all-library-methods (method-function)
+      (do* ((i objc-class-count (1+ i))
+	    (class (id->objc-class i) (id->objc-class i)))
+	   ((eq class 0))
+	(iterate-over-class-methods class method-function)
+	(iterate-over-class-methods (id->objc-metaclass i) method-function))))
+  (def-ccl-pointers revive-objc-classes ()
+    (reset-objc-class-count)))
+
+(defun retain-obcj-object (x)
+  (objc-message-send x "retain"))
 
 #+apple-objc
@@ -76,6 +126,9 @@
                      (nsobject-description (ns-exception c))))))
 
-(def-objc-class ns-lisp-exception ns-exception
-  (lispid :unsigned))
+
+
+(defclass ns-lisp-exception (ns::ns-exception)
+    ((lispid :foreign-type :unsigned))
+  (:metaclass ns::+ns-object))
 
 (define-objc-method ((:id :init-with-lisp-id (:unsigned lisp-id))
@@ -84,9 +137,9 @@
                          :reason #@"lisp exception"
                          :user-info (%null-ptr)))
-  (setq lispid lisp-id)
+  (setf (slot-value self 'lispid) lisp-id)
   self)
 
 (define-objc-method ((:unsigned lisp-id) ns-lisp-exception)
-  lispid)
+  (slot-value self 'lispid))
 
 (defun ns-exception->lisp-condition (nsexception)
@@ -95,4 +148,5 @@
     (id-map-free-object *condition-id-map* (send nsexception 'lisp-id))
     (make-condition 'ns-exception :ns-exception nsexception)))
+
 
 (defmethod ns-exception ((c condition))
@@ -106,5 +160,12 @@
   #|(dbg (format nil "~a" c))|#
   (make-objc-instance 'ns-lisp-exception
-                      :with-lisp-id (assign-id-map-id *condition-id-map* c)))
+		      :with-lisp-id (assign-id-map-id *condition-id-map* c)))
+  
+
+
+(defun ns-exception->lisp-condition (nsexception)
+  (if (typep nsexception 'ns-lisp-exception)
+    (id-map-free-object *condition-id-map* (slot-value nsexception 'lispid))
+    (make-condition 'ns-exception :ns-exception nsexception)))
 
 #+apple-objc
@@ -124,4 +185,6 @@
 
 )
+
+
 
 (defun open-main-bundle ()