summaryrefslogtreecommitdiff
path: root/Lisp
diff options
context:
space:
mode:
Diffstat (limited to 'Lisp')
-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
4 files changed, 66 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))))