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/libobjcl.lisp | 33 +++++++++++++++++++++++++++++++--
 1 file changed, 31 insertions(+), 2 deletions(-)

(limited to 'Lisp/libobjcl.lisp')

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