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/data-types.lisp      |  7 +++++++
 Lisp/libobjcl.lisp        | 41 ++++++++++++++++++-----------------------
 Lisp/type-conversion.lisp | 15 ++++++++++++++-
 3 files changed, 39 insertions(+), 24 deletions(-)

(limited to 'Lisp')

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