From 57d0a7ece7f65a56c09b331fc2af12561632423f Mon Sep 17 00:00:00 2001 From: Matthias Benkard Date: Sun, 17 Feb 2008 18:46:49 +0100 Subject: Play around with %OBJCL-SET-SLOT-VALUE in order to satisfy the test suite. darcs-hash:8fc945e23d662bdf4708c20b20223805218d6860 --- Lisp/class-definition.lisp | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) (limited to 'Lisp/class-definition.lisp') diff --git a/Lisp/class-definition.lisp b/Lisp/class-definition.lisp index 83d85e2..ff091a9 100644 --- a/Lisp/class-definition.lisp +++ b/Lisp/class-definition.lisp @@ -150,8 +150,10 @@ foreign-effective-slot-definition)) (with-slots (foreign-name foreign-type) effective-slot-definition ;; FIXME: Do proper value conversion here (like LOW-LEVEL-INVOKE). - (cffi:with-foreign-object (return-value-cell (typespec->c-type foreign-type)) - (%objcl-get-slot-value (pointer-to instance) foreign-name return-value-cell) + (cffi:with-foreign-object + (return-value-cell (typespec->c-type foreign-type)) + (%objcl-get-slot-value (pointer-to instance) + foreign-name return-value-cell) (mem-ref return-value-cell (typespec->c-type foreign-type))))) @@ -175,19 +177,29 @@ ;; value, this is good news. For everything else, it means just a ;; bit more work. (case (typespec-primary-type foreign-type) - ((struct union id class) + ((struct union id class array) (%objcl-set-slot-value (pointer-to instance) foreign-name (typecase value (c-pointer value) (t (pointer-to value))))) - (otherwise + ((:pointer) + ;; FIXME: Does this make sense? No. Does it work? Must + ;; check. (with-foreign-object (slot-cell (typespec->c-type foreign-type)) (setf (mem-ref slot-cell (typespec->c-type foreign-type)) value) (%objcl-set-slot-value (pointer-to instance) foreign-name - slot-cell))))))) + slot-cell))) + (otherwise + ;; BIG RED FIXME: WTF is _wrong_ with this + ;; object_getInstanceVariable stuff? + ;; + ;; Pure lossage! + (%objcl-set-slot-value (pointer-to instance) + foreign-name + (make-pointer value))))))) (defmethod c2mop:slot-boundp-using-class ((class objective-c-class) -- cgit v1.2.3