Implement FOREIGN-CLASS-ENSURE-REGISTERED.

darcs-hash:cc3448394e3e337be716275c3e4016a542860fd1

3 files changed, 24 insertions, 65 deletions

diff --git a/Lisp/class-definition.lisp b/Lisp/class-definition.lisp
index 28e97dd..61648a6 100644
--- a/Lisp/class-definition.lisp
+++ b/Lisp/class-definition.lisp
@@ -217,7 +217,7 @@
   (let ((key-args (copy-list args)))
     (cond
       ((or (null pointer) (null-pointer-p pointer))
-       (setf (slot-value class 'registered-p) nil)
+       (setf (foreign-class-registered-p class) nil)
        (let* ((ivars (remove-if-not #'(lambda (c)
                                         (typep c 'foreign-direct-slot-definition))
                                     direct-slots))
@@ -238,7 +238,7 @@
                                             ivars))))
          (setf (getf key-args :pointer) new-class-pointer)))
       (t
-       (setf (slot-value class 'registered-p) t)
+       (setf (foreign-class-registered-p class) t)
        ;; We scavenge the class and its superclasses for foreign slots and
        ;; add them to our :DIRECT-SLOTS keyword argument.
        (dolist (objc-slot (objcl-class-direct-slots/pointer pointer))      
@@ -250,56 +250,6 @@
                   :key #'(lambda (slotd) (getf slotd :name))))))
     (apply #'call-next-method class key-args)))
 
-(defmethod initialize-instance ((class objective-c-class)
-                                &key documentation
-                                     name
-                                     plist
-                                     direct-superclasses
-                                     direct-slots
-                                     direct-default-initargs
-                                     pointer
-                                     wrapped-foreign-class)
-  (declare (ignore documentation name plist direct-superclasses direct-slots
-                   direct-default-initargs pointer wrapped-foreign-class))
-  (call-next-method))
-
-(defmethod reinitialize-instance ((class objective-c-class)
-                                  &key documentation
-                                       name
-                                       plist
-                                       direct-superclasses
-                                       direct-slots
-                                       direct-default-initargs
-                                       pointer
-                                       wrapped-foreign-class)
-  (declare (ignore documentation name plist direct-superclasses direct-slots
-                   direct-default-initargs pointer wrapped-foreign-class))
-  (call-next-method))
-
-(defmethod initialize-instance ((class objective-c-meta-class)
-                                &key documentation
-                                     name
-                                     plist
-                                     direct-superclasses
-                                     direct-slots
-                                     direct-default-initargs
-                                     pointer)
-  (declare (ignore documentation name plist direct-superclasses direct-slots
-                   direct-default-initargs pointer))
-  (call-next-method))
-
-(defmethod reinitialize-instance ((class objective-c-meta-class)
-                                  &key documentation
-                                       name
-                                       plist
-                                       direct-superclasses
-                                       direct-slots
-                                       direct-default-initargs
-                                       pointer)
-  (declare (ignore documentation name plist direct-superclasses direct-slots
-                   direct-default-initargs pointer))
-  (call-next-method))
-
 
 (defmethod make-instance :before ((class objective-c-class)
                                   &key
@@ -308,8 +258,11 @@
 
 
 (defun foreign-class-ensure-registered (class)
-  ;; FIXME
-  )
+  (with-exclusive-access (class)
+    (unless (foreign-class-registered-p class)
+      (setf (foreign-class-registered-p class) t)
+      (%objcl-finalise-class (pointer-to class))))
+  class)
 
 
 ;;;; (@* "Quick tests")
diff --git a/Lisp/internal-utilities.lisp b/Lisp/internal-utilities.lisp
index 87746b9..92b003b 100644
--- a/Lisp/internal-utilities.lisp
+++ b/Lisp/internal-utilities.lisp
@@ -18,26 +18,26 @@
 (in-package #:mulk.objective-cl)
 
 
+(defvar *global-lock* (cons nil nil))
+
+
 (defmacro atomically (&body body)
-  ;; FIXME
-  `(progn ,@body)
-  #+(or)
-  `(prog2
-     (objcl-acquire-global-lock)
-     ,@body
-     (objcl-release-global-lock)))
+  `(with-exclusive-access (*global-lock*)
+     ,@body))
 
 
 (defmacro with-exclusive-access ((&rest objects) &body body)
   (etypecase objects
     (null `(progn ,@body))
     (cons `(with-lock ,(first objects)
-             (with-exclusive-access (,(rest objects))
+             (with-exclusive-access ,(rest objects)
                ,@body)))))
 
 
 (defmacro with-lock (object &body body)
   ;; FIXME: Implement LOCK-FOR-OBJECT.
+  `(progn ,@body)
+  #+(or)
   (let ((lock (gensym "LOCK")))
     `(let ((,lock (lock-for-object ,object)))
        (prog2
diff --git a/Lisp/libobjcl.lisp b/Lisp/libobjcl.lisp
index 727bfc5..2308b60 100644
--- a/Lisp/libobjcl.lisp
+++ b/Lisp/libobjcl.lisp
@@ -309,8 +309,12 @@ conventional case for namespace identifiers in Objective-C."
     (if (objc-pointer-null class-ptr)
         nil
         (let ((class-name (objc-class-name->symbol class-name-string))
-              (superclass (or (objcl-class-superclass/pointer class-ptr)
-                              (find-class 'id))))
+              (superclass (let ((potential-superclass
+                                 (objcl-class-superclass/pointer class-ptr)))
+                            (if potential-superclass
+                                (foreign-class-ensure-registered
+                                 potential-superclass)
+                                (find-class 'id)))))
           (or (find-class class-name nil)
               (c2mop:ensure-class class-name
                                   :metaclass (class-name
@@ -365,7 +369,9 @@ conventional case for namespace identifiers in Objective-C."
                (superclass (if non-meta-superclass
                                (find-objc-meta-class
                                 (%objcl-class-name
-                                 (pointer-to non-meta-superclass)))
+                                 (pointer-to
+                                  (foreign-class-ensure-registered
+                                   non-meta-superclass))))
                                (find-class 'objective-c-class)))
                ;; If there is no superclass, we are the root metaclass.
                ;; As we cannot assign ourselves as our own metaclass