diff options
| -rw-r--r-- | Lisp/class-definition.lisp | 61 | ||||
| -rw-r--r-- | Lisp/internal-utilities.lisp | 16 | ||||
| -rw-r--r-- | Lisp/libobjcl.lisp | 12 | ||||
| -rw-r--r-- | Objective-C/libobjcl.m | 8 |
4 files changed, 32 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 diff --git a/Objective-C/libobjcl.m b/Objective-C/libobjcl.m index d02e58b..dc44c2d 100644 --- a/Objective-C/libobjcl.m +++ b/Objective-C/libobjcl.m @@ -499,6 +499,14 @@ objcl_get_slot_value (id obj, const char *ivar_name, void *value_out) value_out is actually a (void *) rather than a (void **). Likewise, the result that is copied to value_out is the slot value itself, not a pointer to it. */ + + /* NOTE UPDATE: Actually, it's trickier than that. The docs for + NeXTstep 3.3 say: ``These functions cannot reliably be used to set + and get instance variables that are not pointers.'' This makes the + behaviour and documentation a bit less confusing, because it means + that value_out is, in fact, assigned a pointer to the value of the + slot under the assumption that the slot itself references its value + via a pointer. */ object_getInstanceVariable (obj, ivar_name, value_out); } |