summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
Diffstat (limited to 'Lisp')
-rw-r--r--Lisp/defpackage.lisp2
-rw-r--r--Lisp/libobjcl.lisp33
2 files changed, 33 insertions, 2 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))