From 938a371de94ecbe2b4ccc72670dbfc8a68b50aa1 Mon Sep 17 00:00:00 2001
From: Matthias Benkard <code@mail.matthias.benkard.de>
Date: Sun, 17 Feb 2008 14:17:53 +0100
Subject: Fix ENSURE-OBJECTIVE-C-CLASS-PAIR.

darcs-hash:cd2b28bb4e252e25afb6807e32d092fcbd9c0977
---
 Lisp/class-definition.lisp | 36 +++++++++++++++++++++++++-----------
 Lisp/libobjcl.lisp         | 15 +++++++++------
 Objective-C/libobjcl.h     |  3 +++
 Objective-C/libobjcl.m     | 11 +++++++++++
 4 files changed, 48 insertions(+), 17 deletions(-)

diff --git a/Lisp/class-definition.lisp b/Lisp/class-definition.lisp
index 11d3767..3eb10ee 100644
--- a/Lisp/class-definition.lisp
+++ b/Lisp/class-definition.lisp
@@ -220,9 +220,11 @@
             (0 (find-objc-class "NSObject"))
             (1 (first objective-c-superclasses))
             (otherwise
-             (error "At most one Objective-C class may be derived at once."))))
-         (ivars (remove-if-not #'(lambda (c)
-                                   (typep c 'foreign-direct-slot-definition))
+             (error "Tried to derive all of ~S at the same time.  ~
+                    (At most one Objective-C class may be derived at once.)"
+                    objective-c-superclasses))))
+         (ivars (remove-if-not #'(lambda (x)
+                                   (getf x :foreign-type nil))
                                direct-slots))
          (new-class-pointer
           (objcl-create-class (symbol->objc-class-name name)
@@ -230,23 +232,29 @@
                                            (typep c 'objective-c-class))
                                        direct-superclasses)
                               nil
-                              (mapcar #'slot-definition-foreign-name
+                              (mapcar #'(lambda (x)
+                                          (getf x :foreign-name
+                                                (slot-name->foreign-slot-name
+                                                 (getf x :name))))
                                       ivars)
                               (mapcar #'(lambda (x)
-                                          (slot-definition-foreign-type x))
+                                          (getf x :foreign-type))
                                       ivars)))
          (metaclass
-          (ensure-class name
+          (ensure-class (objc-meta-class-name->symbol
+                         (symbol->objc-class-name name))
                         :metaclass (class-of (class-of superclass))
-                        :pointer new-class-pointer
-                        :direct-superclasses (list (class-of superclass))))
+                        :pointer (%objcl-class-metaclass new-class-pointer)
+                        :direct-superclasses (list (class-of superclass))
+                        :new-foreign-class-p t))
          (class
           (ensure-class name
                         :metaclass metaclass
                         :pointer new-class-pointer
                         :direct-slots direct-slots
                         :direct-superclasses direct-superclasses
-                        :direct-default-initargs direct-default-initargs)))
+                        :direct-default-initargs direct-default-initargs
+                        :new-foreign-class-p t)))
     class))
 
 
@@ -281,6 +289,11 @@
         (t (call-next-method))))
 
 
+(defmethod reinitialize-instance ((class objective-c-class)
+                                  &key &allow-other-keys)
+  (call-next-method))
+
+
 (defmethod initialize-instance :around ((class objective-c-class)
                                         &rest args
                                         &key pointer
@@ -305,7 +318,8 @@
 (defmethod make-instance :before ((class objective-c-class)
                                   &key
                                   &allow-other-keys)
-  (foreign-class-ensure-registered class))
+  (unless (typep class 'objective-c-meta-class)
+    (foreign-class-ensure-registered class)))
 
 
 (defun foreign-class-ensure-registered (class)
@@ -339,6 +353,6 @@
             :initform nil
             :initarg :foos
             :accessor mlk-string-foos)
-      (foo-count :foreign-type '(:integer ())))
+      (foo-count :foreign-type (:int ())))
   (:metaclass #+(or) objective-c-class
               ns:+ns-object))
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index 1364c58..47c39a9 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -57,6 +57,9 @@
 (defcfun ("objcl_class_superclass" %objcl-class-superclass) :pointer
   (obj :pointer))
 
+(defcfun ("objcl_class_metaclass" %objcl-class-metaclass) :pointer
+  (obj :pointer))
+
 (defcfun ("objcl_find_selector" %objcl-find-selector) :pointer
   (selector-name :string))
 
@@ -768,12 +771,12 @@ separating parts by hyphens works nicely in all of the `:INVERT`,
                                                          list)
                                                  :pointer)))
         (%objcl-create-class class-name
-                         (pointer-to superclass)
-                         (length protocol-names)
-                         %protocol-names
-                         (length ivar-names)
-                         %ivar-names
-                         %ivar-typestrings)))))
+                             (pointer-to superclass)
+                             (length protocol-names)
+                             %protocol-names
+                             (length ivar-names)
+                             %ivar-names
+                             %ivar-typestrings)))))
 
 ;;; (@* "Low-level Data Conversion")
 (eval-when (:compile-toplevel :load-toplevel)
diff --git a/Objective-C/libobjcl.h b/Objective-C/libobjcl.h
index 758c831..89292f4 100644
--- a/Objective-C/libobjcl.h
+++ b/Objective-C/libobjcl.h
@@ -90,6 +90,9 @@ objcl_class_name (Class class);
 Class
 objcl_class_superclass (Class class);
 
+MetaClass
+objcl_class_metaclass (Class class);
+
 const char *
 objcl_selector_name (SEL selector);
 
diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m
index dc44c2d..c933e49 100644
--- a/Objective-C/libobjcl.m
+++ b/Objective-C/libobjcl.m
@@ -284,6 +284,17 @@ objcl_class_superclass (Class class)
 }
 
 
+MetaClass
+objcl_class_metaclass (Class class)
+{
+#ifdef __NEXT_RUNTIME__
+  return objc_getMetaClass (class);
+#else
+  return class_get_meta_class (class);
+#endif
+}
+
+
 const char *
 objcl_selector_name (SEL selector)
 {
-- 
cgit v1.2.3