From c191d8f49e58bbc5b769780a0a17b5cec82174f1 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Mon, 6 Aug 2007 17:39:18 +0200
Subject: Make class and selector name retrieval more portable.

darcs-hash:f7a369dba0dda3e067547210ce7c008ae60cdc05
---
 Lisp/libobjcl.lisp | 41 ++++++++++++++++++-----------------------
 1 file changed, 18 insertions(+), 23 deletions(-)

(limited to 'Lisp/libobjcl.lisp')

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)
-- 
cgit v1.2.3