From 620a94200d9d7a33e41afd77c275599feb259ebd Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Sun, 17 Feb 2008 11:20:27 +0100 Subject: Implement FOREIGN-CLASS-ENSURE-REGISTERED. darcs-hash:cc3448394e3e337be716275c3e4016a542860fd1 --- Lisp/class-definition.lisp | 61 +++++--------------------------------------- Lisp/internal-utilities.lisp | 16 ++++++------ Lisp/libobjcl.lisp | 12 ++++++--- 3 files changed, 24 insertions(+), 65 deletions(-) (limited to 'Lisp') 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 -- cgit v1.2.3