From 6bda4966b9885c19dff28fe218a2923bc2ecd4db Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Wed, 26 Sep 2007 00:40:55 +0200
Subject: Add FIND-OBJC-META-CLASS, fix some minor bugs.

darcs-hash:1ae0dd35e64b278b944bc797847ccfedb97ea471
---
 Lisp/defpackage.lisp   |  2 ++
 Lisp/libobjcl.lisp     | 33 +++++++++++++++++++++++++++++++--
 Objective-C/libobjcl.h |  3 +++
 Objective-C/libobjcl.m | 20 ++++++++++++++++++++
 objective-cl.asd       |  3 ++-
 5 files changed, 58 insertions(+), 3 deletions(-)

diff --git a/Lisp/defpackage.lisp b/Lisp/defpackage.lisp
index a01ace0..34e7f1f 100644
--- a/Lisp/defpackage.lisp
+++ b/Lisp/defpackage.lisp
@@ -28,6 +28,8 @@
            #:invoke
            #:find-objc-class
            #:find-selector
+           #:objc-class-name
+           #:selector-name
            #:selector
 
            ;; Generic functions
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index e5bff30..5f8d80f 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -52,6 +52,9 @@
 (defcfun ("objcl_find_class" %objcl-find-class) :pointer
   (class-name :string))
 
+(defcfun ("objcl_find_meta_class" %objcl-find-meta-class) :pointer
+  (class-name :string))
+
 (defcfun ("objcl_class_name" %objcl-class-name) :string
   (class :pointer))
 
@@ -221,7 +224,7 @@ conventional case for namespace identifiers in Objective C."
                 find-objc-class-by-name))
 (defun find-objc-class-by-name (class-name)
   (let ((class-ptr (%objcl-find-class class-name)))
-    (if (cffi:null-pointer-p class-ptr)
+    (if (objc-pointer-null class-ptr)
         nil
         #-(or t openmcl) (make-pointer-wrapper 'objc-class :pointer class-ptr)
         #+(and nil openmcl) (change-class (make-pointer-wrapper 'c-pointer-wrapper
@@ -229,6 +232,32 @@ conventional case for namespace identifiers in Objective C."
                                           'objc-class))))
 
 
+(defun find-objc-meta-class (meta-class-name &optional errorp)
+  (let ((meta-class
+         (etypecase meta-class-name
+           (string (find-objc-meta-class-by-name meta-class-name))
+           (symbol (find-objc-meta-class-by-name
+                    (symbol->objc-class-name meta-class-name))))))
+    (or meta-class (if errorp
+                       (error "Found no Objective C metaclass named ~S."
+                              meta-class-name)
+                       nil))))
+
+
+(defun find-objc-meta-class-by-name (class-name)
+  (let ((class-ptr (%objcl-find-meta-class class-name)))
+    (if (objc-pointer-null class-ptr)
+        nil
+        #-(or t openmcl) (make-pointer-wrapper 'objc-meta-class :pointer class-ptr)
+        #+(and nil openmcl) (change-class (make-pointer-wrapper 'c-pointer-wrapper
+                                             :pointer value)
+                                          'objc-meta-class))))
+
+(defun objc-pointer-null (pointer)
+  (or (cffi:null-pointer-p pointer)
+      (cffi:pointer-eq pointer (objcl-get-nil))))
+
+
 (declaim (ftype (function (string) (or null selector))
                 find-selector-by-name))
 (defun find-selector-by-name (selector-name)
@@ -251,7 +280,7 @@ conventional case for namespace identifiers in Objective C."
   (%objcl-selector-name (pointer-to selector)))
 
 
-(declaim (ftype (function ((or id objc-class exception) selector) *)
+(declaim (ftype (function ((or id objc-class exception) selector) t)
                 get-method-implementation))
 (defun get-method-implementation (object selector)
   (declare (type selector selector))
diff --git a/Objective-C/libobjcl.h b/Objective-C/libobjcl.h
index 35fd0c8..56ba2d7 100644
--- a/Objective-C/libobjcl.h
+++ b/Objective-C/libobjcl.h
@@ -43,6 +43,9 @@ objcl_invoke_with_types (int argc,
 Class
 objcl_find_class (const char *class_name);
 
+Class
+objcl_find_meta_class (const char *class_name);
+
 SEL
 objcl_find_selector (const char *selector_name);
 
diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m
index c13f252..6f09cfe 100644
--- a/Objective-C/libobjcl.m
+++ b/Objective-C/libobjcl.m
@@ -128,7 +128,27 @@ objcl_invoke_with_types (int argc,
 Class
 objcl_find_class (const char *class_name)
 {
+#ifdef __NEXT_RUNTIME__
+  return objc_lookUpClass (class_name);
+#else
   return NSClassFromString ([NSString stringWithUTF8String: class_name]);
+#endif
+}
+
+
+Class
+objcl_find_meta_class (const char *class_name)
+{
+#ifdef __NEXT_RUNTIME__
+  return objc_getMetaClass (class_name);
+#else
+  /* FIXME: Is this correct? */
+  Class class = objcl_find_class (class_name);
+  if (class == NULL || class == nil)
+    return NULL;
+  else
+    return class_get_meta_class (class);
+#endif
 }
 
 
diff --git a/objective-cl.asd b/objective-cl.asd
index 0a347a0..b195e3c 100644
--- a/objective-cl.asd
+++ b/objective-cl.asd
@@ -25,7 +25,8 @@
   ((:module "Lisp"
     :components ((:file "defpackage")
                  (:file "constant-data"      :depends-on ("defpackage"))
-                 (:file "data-types"         :depends-on ("defpackage"))
+                 (:file "data-types"         :depends-on ("defpackage"
+                                                          "conditions"))
                  (:file "parameters"         :depends-on ("defpackage"))
                  (:file "name-conversion"    :depends-on ("defpackage"))
                  (:file "internal-utilities" :depends-on ("defpackage"))
-- 
cgit v1.2.3