From 9197694fe9fd4eaa6e2c11f0acc92ef60ab6110a Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Fri, 14 Sep 2007 03:26:32 +0200
Subject: New C function: objcl_get_method_implementation.

darcs-hash:de2f77980605c7aec911673edb0f0f29d0467fce
---
 Lisp/libobjcl.lisp     | 23 ++++++++++++++++++++---
 Objective-C/libobjcl.h |  4 ++++
 Objective-C/libobjcl.m | 33 +++++++++++++++++++++++++++++++++
 3 files changed, 57 insertions(+), 3 deletions(-)

diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index bc84a44..176423c 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -86,9 +86,16 @@ objects or classes, let alone send messages to them.
 (defcfun ("objcl_selector_name" %objcl-selector-name) :pointer
   (selector obj-data))
 
+(defcfun ("objcl_get_method_implementation"
+          %objcl-get-method-implementation)
+    :pointer
+  (object obj-data)
+  (selector obj-data))
 
-(declaim (ftype (function ((or string symbol)) (or null objc-class))
-                find-objc-class-by-name))
+
+(declaim (ftype (function ((or string symbol) &optional t)
+                          (or null objc-class))
+                find-objc-class))
 (defun find-objc-class (class-name &optional errorp)
   "Retrieve an Objective C class by name.
 
@@ -177,7 +184,8 @@ conventional case for namespace identifiers in Objective C."
         (the selector (obj-data->lisp obj-data)))))
 
 
-(declaim (ftype (function (objc-class) string) objcl-class-name))
+(declaim (ftype (function ((or objc-class id exception)) string)
+                objcl-class-name))
 (defun objcl-class-name (class)
   (declare (type (or objc-class id exception) class))
   (with-foreign-conversion ((obj-data class))
@@ -191,6 +199,15 @@ conventional case for namespace identifiers in Objective C."
     (foreign-string-to-lisp/dealloc (%objcl-selector-name obj-data))))
 
 
+(declaim (ftype (function ((or id objc-class exception) selector) *)
+                get-method-implementation))
+(defun get-method-implementation (object selector)
+  (declare (type selector selector))
+  (with-foreign-conversion ((sel-obj-data selector)
+                            (obj-obj-data object))
+    (%objcl-get-method-implementation obj-obj-data sel-obj-data)))
+
+
 (declaim (ftype (function ((or selector string list)) selector)
                 selector))
 (defun selector (designator)
diff --git a/Objective-C/libobjcl.h b/Objective-C/libobjcl.h
index 270fa78..cb47440 100644
--- a/Objective-C/libobjcl.h
+++ b/Objective-C/libobjcl.h
@@ -60,3 +60,7 @@ objcl_class_name (OBJCL_OBJ_DATA class);
 
 const char *
 objcl_selector_name (OBJCL_OBJ_DATA class);
+
+IMP
+objcl_get_method_implementation (OBJCL_OBJ_DATA object,
+                                 OBJCL_OBJ_DATA selector);
diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m
index 2e24f71..833a4fb 100644
--- a/Objective-C/libobjcl.m
+++ b/Objective-C/libobjcl.m
@@ -333,3 +333,36 @@ objcl_selector_name (OBJCL_OBJ_DATA selector)
 
   return name;
 }
+
+
+IMP
+objcl_get_method_implementation (OBJCL_OBJ_DATA object,
+                                 OBJCL_OBJ_DATA selector)
+{
+  id obj;
+
+  if (strcmp (selector->type, @encode (SEL)) != 0)
+    return NULL;
+
+  switch (object->type[0])
+    {
+    case '#':
+      obj = object->data.class_val;
+      break;
+    case '@':
+      obj = object->data.id_val;
+      break;
+    case 'E':
+      obj = (id) object->data.exc_val;
+      break;
+    default:
+      return NULL;
+    }
+
+#ifdef __NEXT_RUNTIME__
+  return class_getInstanceMethod ([obj class],
+                                  selector->data.sel_val)->method_imp;
+#else
+  return objc_msg_lookup (obj, selector->data.sel_val);
+#endif
+}
-- 
cgit v1.2.3