From c93a74f1befea75be769fb47968e67568139954d Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Tue, 18 Sep 2007 00:50:47 +0200 Subject: Objective-C layer: Add functions for dealing with classes and metaclasses. darcs-hash:9ce15bb5fff3fb127cf4f6b72e70fa58c1cc2345 --- Lisp/data-types.lisp | 7 ++++++ Lisp/libobjcl.lisp | 35 +++++++++++++++++++++++++++++ Lisp/method-invocation.lisp | 5 ++--- Lisp/utilities.lisp | 33 ++++++++++++++++++--------- Objective-C/libobjcl.h | 12 ++++++++++ Objective-C/libobjcl.m | 55 +++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 133 insertions(+), 14 deletions(-) diff --git a/Lisp/data-types.lisp b/Lisp/data-types.lisp index 533578b..7b07624 100644 --- a/Lisp/data-types.lisp +++ b/Lisp/data-types.lisp @@ -108,6 +108,13 @@ a suitable class method instead as you would in Objective C. (:documentation "")) +(defclass objc-meta-class (c-pointer-wrapper) + ((meta-class-for-class :type (or null id objc-class) + :initarg :meta-class-for-class + :reader meta-class-for-class)) + (:documentation "")) + + (define-condition exception (error) ((pointer :type c-pointer :accessor pointer-to diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp index ffe166f..fd7caca 100644 --- a/Lisp/libobjcl.lisp +++ b/Lisp/libobjcl.lisp @@ -57,6 +57,20 @@ (object obj-data) (selector obj-data)) +(defcfun ("objcl_object_is_class" %objcl-object-is-class) :boolean + (obj :pointer)) + +(defcfun ("objcl_object_is_meta_class" %objcl-object-is-meta-class) + :boolean + (obj :pointer)) + +(defcfun ("objcl_object_get_class" %objcl-object-get-class) :pointer + (obj :pointer)) + +(defcfun ("objcl_object_get_meta_class" %objcl-object-get-meta-class) + :pointer + (obj :pointer)) + (defun initialise-runtime () "Initialise the Objective C runtime. @@ -284,6 +298,27 @@ by which __invoke__ converts its arguments into a *message name*. selector-name))))) +(defun object-is-class-p (obj) + (%objcl-object-is-class (pointer-to obj))) + +(defun object-is-meta-class-p (obj) + (%objcl-object-is-meta-class (pointer-to obj))) + +(defun object-get-class (obj) + (make-instance 'objc-class + :pointer (%objcl-object-get-class (pointer-to obj)))) + +(defun object-get-meta-class (obj) + (make-instance 'objc-meta-class + :pointer (%objcl-object-get-meta-class (pointer-to obj)) + :meta-class-for-class (object-get-class obj))) + +(defun objc-class-of (obj) + (cond ((object-is-meta-class-p obj) + (error "Tried to get the class of meta class ~S." obj)) + ((object-is-class-p obj) (object-get-meta-class obj)) + (t (object-get-class obj)))) + ;;; (@* "Low-level Data Conversion") (eval-when (:compile-toplevel :load-toplevel) ;; In order to be able to dispatch over pointer types, we need to diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp index bc6cc2d..e290e50 100644 --- a/Lisp/method-invocation.lisp +++ b/Lisp/method-invocation.lisp @@ -392,15 +392,14 @@ Returns: *result* --- the return value of the method invocation. (defun invoke-with-conversion (receiver method-name &rest args) (let* ((selector (selector method-name)) - (class (primitive-invoke receiver 'class 'objc-class))) + (class (object-get-class receiver))) (multiple-value-bind (argc method-return-typestring method-return-type method-arg-typestrings method-arg-types) (retrieve-method-signature-info class selector - (if (cffi:pointer-eq (pointer-to receiver) - (pointer-to class)) + (if (object-is-class-p receiver) :class :instance)) (assert (= argc (+ 2 (length args))) diff --git a/Lisp/utilities.lisp b/Lisp/utilities.lisp index 2e8839c..710ac94 100644 --- a/Lisp/utilities.lisp +++ b/Lisp/utilities.lisp @@ -95,32 +95,43 @@ ;;; (@* "Object Representation") (defmethod print-object ((object id) stream) (print-unreadable-object (object stream) - (format stream "~A `~A' {~X}" - (objcl-class-name (primitive-invoke object "class" 'id)) - (primitive-invoke (primitive-invoke object "description" 'id) - "UTF8String" :string) - (primitive-invoke object "hash" :unsigned-int)))) + (with-slots (pointer) object + (format stream "~A `~A' {~X}" + (objcl-class-name (primitive-invoke object "class" 'id)) + (primitive-invoke (primitive-invoke object "description" 'id) + "UTF8String" :string) + (cffi:pointer-address pointer))))) (defmethod print-object ((class objc-class) stream) (print-unreadable-object (class stream) - (format stream "~S ~A {~X}" - 'objc-class - (objcl-class-name class) - (primitive-invoke class "hash" :unsigned-int)))) + (with-slots (pointer) class + (format stream "~S ~A {~X}" + (type-of class) + (objcl-class-name class) + (cffi:pointer-address pointer))))) + + +(defmethod print-object ((meta-class objc-meta-class) stream) + (print-unreadable-object (meta-class stream) + (with-slots (meta-class-for-class pointer) meta-class + (format stream "~S ~A {~X}" + (type-of meta-class) + (objcl-class-name meta-class-for-class) + (cffi:pointer-address pointer))))) (defmethod print-object ((selector selector) stream) (print-unreadable-object (selector stream) (format stream "~S `~A'" - 'selector + (type-of selector) (selector-name selector)))) (defmethod print-object ((exception exception) stream) (print-unreadable-object (exception stream) (format stream "~S ~A {~X}" - 'exception + (type-of exception) (primitive-invoke (primitive-invoke exception "name" 'id) "UTF8String" :string) (primitive-invoke exception "hash" :unsigned-int)))) diff --git a/Objective-C/libobjcl.h b/Objective-C/libobjcl.h index d2f5e76..27ffd01 100644 --- a/Objective-C/libobjcl.h +++ b/Objective-C/libobjcl.h @@ -79,3 +79,15 @@ objcl_selector_name (OBJCL_OBJ_DATA class); IMP objcl_get_method_implementation (OBJCL_OBJ_DATA object, OBJCL_OBJ_DATA selector); + +BOOL +objcl_object_is_class (id obj); + +BOOL +objcl_object_is_meta_class (id obj); + +Class +objcl_object_get_class (id obj); + +Class +objcl_object_get_meta_class (id obj); diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m index 25fc11f..bc89a32 100644 --- a/Objective-C/libobjcl.m +++ b/Objective-C/libobjcl.m @@ -447,3 +447,58 @@ objcl_get_method_implementation (OBJCL_OBJ_DATA object, return objc_msg_lookup (obj, selector->data.sel_val); #endif } + + +BOOL +objcl_object_is_class (id obj) +{ +#ifdef __NEXT_RUNTIME__ + return [obj class] == obj +#else + /* return CLS_ISCLASS (obj); */ + return object_is_class (obj); +#endif +} + + +BOOL +objcl_object_is_meta_class (id obj) +{ +#ifdef __NEXT_RUNTIME__ + /* FIXME: What to do here? */ + return [[obj class] metaClass] == obj; +#else + /* return CLS_ISMETA (ptr); */ + if (objcl_object_is_class (obj)) + return class_is_meta_class (obj); + else + return object_is_meta_class (obj); +#endif +} + + +Class +objcl_object_get_class (id obj) +{ +#ifdef __NEXT_RUNTIME__ + /* XXX? return obj->isa; */ + return [obj class]; +#else + return object_get_class (obj); +#endif +} + + +Class +objcl_object_get_meta_class (id obj) +{ +#ifdef __NEXT_RUNTIME__ + /* FIXME: What to do here? */ + return [[obj class] metaClass]; +#else + if (objcl_object_is_class (obj)) + return class_get_meta_class (obj); + else + return object_get_meta_class (obj); +#endif +} -- cgit v1.2.3