Objective-C layer: Add functions for dealing with classes and metaclasses.

darcs-hash:9ce15bb5fff3fb127cf4f6b72e70fa58c1cc2345

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))))