summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Lisp/data-types.lisp7
-rw-r--r--Lisp/libobjcl.lisp35
-rw-r--r--Lisp/method-invocation.lisp5
-rw-r--r--Lisp/utilities.lisp33
-rw-r--r--Objective-C/libobjcl.h12
-rw-r--r--Objective-C/libobjcl.m55
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
+}
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-18 14:10:49 +0000