Make class and selector name retrieval more portable.

darcs-hash:f7a369dba0dda3e067547210ce7c008ae60cdc05

5 files changed, 65 insertions, 27 deletions

diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp
index 6181a3b..16d9147 100644
--- a/Lisp/data-types.lisp
+++ b/Lisp/data-types.lisp
@@ -98,6 +98,13 @@
             (invoke-by-name class "hash"))))
 
 
+(defmethod print-object ((selector selector) stream)
+  (print-unreadable-object (selector stream)
+    (format stream "~S `~A'"
+            'selector
+            (selector-name selector))))
+
+
 (defmethod print-object ((exception exception) stream)
   (print-unreadable-object (exception stream)
     (format stream "~S ~A {~X}"
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index ad13358..fff0963 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -90,6 +90,9 @@ objects or classes, let alone send messages to them.
 (defcfun ("objcl_find_selector" %objcl-find-selector) :pointer
   (selector-name :string))
 
+(defcfun ("objcl_selector_name" %objcl-selector-name) :string
+  (selector obj-data))
+
 
 (defun find-objc-class (class-name)
   "Retrieve an Objective C class by name.
@@ -145,34 +148,26 @@ conventional case for namespace identifiers in Objective C."
 
 (defun find-objc-class-by-name (class-name)
   (let ((obj-data (%objcl-find-class class-name)))
-    (prog1
-        (if (null-pointer-p (foreign-slot-value
-                             (foreign-slot-value obj-data 'obj-data 'data)
-                             'obj-data-union
-                             'class-val))
-            nil
-            (obj-data->lisp obj-data))
+    (unwind-protect
+         (if (null-pointer-p (foreign-slot-value
+                              (foreign-slot-value obj-data 'obj-data 'data)
+                              'obj-data-union
+                              'class-val))
+             nil
+             (obj-data->lisp obj-data))
       (dealloc-obj-data obj-data))))
 
 
 (defun objcl-class-name (class)
   (declare (type (or objc-class id exception) class))
-  (let ((obj-data (foreign-alloc 'obj-data)))
-    (with-foreign-slots ((type data) obj-data obj-data)
-      (setf (foreign-slot-value data
-                                'obj-data-union
-                                (etypecase class
-                                  (objc-class     'class-val)
-                                  (id        'id-val)
-                                  (exception 'exc-val)))
-            (pointer-to class))
-      (setf type (foreign-string-alloc (etypecase class
-                                         (objc-class "#")
-                                         (id         "@")
-                                         (exception  "E")))))
-    (prog1
-        (%objcl-class-name obj-data)
-      (dealloc-obj-data obj-data))))
+  (with-foreign-objects ((obj-data class))
+    (%objcl-class-name obj-data)))
+
+
+(defun selector-name (selector)
+  (declare (type selector selector))
+  (with-foreign-objects ((obj-data selector))
+    (%objcl-selector-name obj-data)))
 
 
 (defun find-selector (selector-name)
diff --git a/Lisp/type-conversion.lisp b/Lisp/type-conversion.lisp
index 8839b3b..3ac1ce6 100644
--- a/Lisp/type-conversion.lisp
+++ b/Lisp/type-conversion.lisp
@@ -32,4 +32,17 @@
         ((id objc-class selector exception)
          (make-instance lisp-type :pointer value))
         ((string)  (foreign-string-to-lisp value))
-        (otherwise value)))))
\ No newline at end of file
+        (otherwise value)))))
+
+
+(defmacro with-foreign-objects (bindings &body body)
+  `(let ,(mapcar #'(lambda (name-value-pair)
+                     (destructuring-bind (name value)
+                         name-value-pair
+                       `(,name (lisp->obj-data ,value))))
+                 bindings)
+     (unwind-protect
+          (progn ,@body)
+       ,@(mapcar #'(lambda (name-value-pair)
+                     `(dealloc-obj-data ,(first name-value-pair)))
+                 bindings))))
diff --git a/Objective-C/libobjcl.h b/Objective-C/libobjcl.h
index eefeb5e..e8bcfaf 100644
--- a/Objective-C/libobjcl.h
+++ b/Objective-C/libobjcl.h
@@ -63,3 +63,6 @@ objcl_query_arglist_info (void *receiver,
 
 const char *
 objcl_class_name (OBJCL_OBJ_DATA class);
+
+const char *
+objcl_selector_name (OBJCL_OBJ_DATA class);
diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m
index 7208498..916ffa3 100644
--- a/Objective-C/libobjcl.m
+++ b/Objective-C/libobjcl.m
@@ -293,10 +293,10 @@ objcl_find_selector (const char *class_name)
 const char *
 objcl_class_name (OBJCL_OBJ_DATA class)
 {
+  const char *ns_name;
+  char *name;
   Class cls = NULL;
 
-  /* fprintf (stderr, "---------> %s <--------\n", class->type); */
-  fflush (stderr);
   assert (class->type[0] == '#'
           || class->type[0] == '@'
           || class->type[0] == 'E');
@@ -307,5 +307,25 @@ objcl_class_name (OBJCL_OBJ_DATA class)
     case 'E': cls = (id) class->data.exc_val;
     }
 
-  return class_get_class_name (cls);
+  ns_name = [(NSStringFromClass (cls)) UTF8String];
+  name = malloc (strlen (ns_name) + 1);
+  strcpy (name, ns_name);
+
+  return name;
+}
+
+
+const char *
+objcl_selector_name (OBJCL_OBJ_DATA selector)
+{
+  const char *ns_name;
+  char *name;
+
+  assert (selector->type[0] == ':');
+  ns_name = [(NSStringFromSelector (selector->data.sel_val))
+              UTF8String];
+  name = malloc (strlen (ns_name) + 1);
+  strcpy (name, ns_name);
+
+  return name;
 }