From 3f06b3a67a1d2ca8ef3eafffb4d67bd8b0ae47e8 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Wed, 6 Feb 2008 21:23:01 +0100
Subject: Assign a fake metaclass as a metaclass to the root metaclass.

darcs-hash:e594ffa7fa03edfdbfd4f44708c2a1863c96a2af
---
 Lisp/class-definition.lisp |  5 ++--
 Lisp/libobjcl.lisp         | 57 +++++++++++++++++++++++-----------------------
 Lisp/name-conversion.lisp  |  9 ++++++++
 3 files changed, 39 insertions(+), 32 deletions(-)

(limited to 'Lisp')

diff --git a/Lisp/class-definition.lisp b/Lisp/class-definition.lisp
index 54af234..85f3eb6 100644
--- a/Lisp/class-definition.lisp
+++ b/Lisp/class-definition.lisp
@@ -215,9 +215,8 @@
   ;; add them to our :DIRECT-SLOTS keyword argument.
   (let ((key-args (copy-list args)))
     (dolist (objc-slot (objcl-class-direct-slots/pointer pointer))      
-      (pushnew (list :name (intern (foreign-slot-name->slot-name
-                                    (objcl-slot-name objc-slot))
-                                   (find-package '#:objective-c-classes))
+      (pushnew (list :name (foreign-slot-name->slot-name
+                            (objcl-slot-name objc-slot))
                      :foreign-name (objcl-slot-name objc-slot)
                      :foreign-type (parse-typespec (objcl-slot-type objc-slot)))
                (getf key-args :direct-slots)
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index 536938e..07f88ac 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -296,37 +296,36 @@ conventional case for namespace identifiers in Objective-C."
                                (find-objc-meta-class
                                 (%objcl-class-name
                                  (pointer-to non-meta-superclass)))
-                               (find-class 'objective-c-class))))
+                               (find-class 'objective-c-class)))
+               ;; If there is no superclass, we are the root metaclass.
+               ;; As we cannot assign ourselves as our own metaclass
+               ;; (which is a pity, because it would be the correct thing
+               ;; to do), we generate a fake metaclass for ourselves that
+               ;; is almost the same as ourselves except for its own
+               ;; metaclass, which is OBJECTIVE-C-META-CLASS.  (As we are
+               ;; probably +NS-OBJECT, this fake metaclass will be called
+               ;; ++NS-OBJECT.)
+               ;;
+               ;; If the superclass is the root metaclass, we take it as
+               ;; our metaclass, because the root metaclass is the
+               ;; metaclass of all metaclasses.
+               ;;
+               ;; Otherwise, we use the metaclass of the superclass as
+               ;; our own, which will always get us the root metaclass.
+               (metaclass
+                (if non-meta-superclass
+                    (if (typep (class-of superclass)
+                               'objective-c-meta-class)
+                        superclass
+                        (class-of superclass))
+                    (c2mop:ensure-class
+                     (objc-fake-meta-class-name->symbol class-name-string)
+                     :metaclass 'objective-c-meta-class
+                     :pointer class-ptr
+                     :direct-superclasses (list superclass)))))
           (or (find-class class-name nil)
               (c2mop:ensure-class class-name
-                                  ;; If there is no superclass, we are
-                                  ;; the root metaclass.  As we cannot
-                                  ;; assign ourselves as our own
-                                  ;; metaclass (which is a pity, because
-                                  ;; it would be the correct thing to
-                                  ;; do), we use OBJECTIVE-C-META-CLASS
-                                  ;; as our metaclass and regrettably
-                                  ;; miss out on some features.  (Sorry,
-                                  ;; you can't get at +NS-OBJECT's
-                                  ;; slots.)
-                                  ;;
-                                  ;; If the superclass is the root
-                                  ;; metaclass, we take it as our
-                                  ;; metaclass, because the root
-                                  ;; metaclass is the metaclass of all
-                                  ;; metaclasses.
-                                  ;;
-                                  ;; Otherwise, we use the metaclass of
-                                  ;; the superclass as our own, which
-                                  ;; will always get us the root
-                                  ;; metaclass.
-                                  :metaclass (if non-meta-superclass
-                                                 (if (eq (class-name
-                                                          (class-of superclass))
-                                                         'objective-c-meta-class)
-                                                     superclass
-                                                     (class-of superclass))
-                                                 'objective-c-meta-class)
+                                  :metaclass metaclass
                                   :pointer class-ptr
                                   :direct-superclasses (list superclass)))))))
 
diff --git a/Lisp/name-conversion.lisp b/Lisp/name-conversion.lisp
index dcff468..84a0c82 100644
--- a/Lisp/name-conversion.lisp
+++ b/Lisp/name-conversion.lisp
@@ -106,6 +106,15 @@
                    (symbol-name (objc-class-name->symbol meta-class-name)))))))
 
 
+(defun objc-fake-meta-class-name->symbol (meta-class-name)
+  (let ((*package* (find-package '#:objective-c-classes)))
+    (export-and-return
+     (intern
+      (concatenate 'string
+                   "++"
+                   (symbol-name (objc-class-name->symbol meta-class-name)))))))
+
+
 (defun name-hyphenated->mixed-case (string &optional (case-convention :nerd-caps))
   (let ((lower-case-string (name->canonised-lower-case string)))
     (ecase case-convention
-- 
cgit v1.2.3