Wed Sep 2 13:49:34 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Various fixes:
* Allow user conversions for return values
* fix destruction of objects with multiple C++ superclasses
* Fix list to QList conversion dispatch
diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp
--- old-smoke/src/clos.lisp 2014-10-30 07:05:47.000000000 +0100
+++ new-smoke/src/clos.lisp 2014-10-30 07:05:47.000000000 +0100
@@ -267,6 +267,11 @@
;; in a finalizer. In that case the object is already removed from
;; *object-map* when the callback is invoked. Thus OBJECT can be NIL.
(when object
+ (when (typep object 'smoke-multi-superclass-mixin)
+ (dolist (extra-object (extra-objects object))
+ (unless (null-pointer-p (pointer extra-object))
+ (remove-object (pointer extra-object))
+ (delete-object extra-object))))
(remove-finalizer object)
(remove-object object-pointer)
(setf (slot-value object 'pointer) (null-pointer)))))
@@ -289,32 +294,34 @@
arg)
args))))
-(defun convert-argument (argument type &optional (user t))
- "Returns ARGUMENT converted to TYPE. If USER is true, user defined
-conversion sequences are considered."
- (let ((rank (get-conversion-sequence argument type user)))
- (if (null rank)
- (error "Can not convert the argument ~S to ~A."
- argument (name type))
- (funcall (conversion-function-name rank)
- argument))))
+(defun convert-argument (argument type &optional disown)
+ "Returns ARGUMENT converted to TYPE and removes the ownership when
+it is passed on the stack."
+ (flet ((disown (object)
+ (remove-finalizer object)
+ (when (typep object 'smoke-standard-object)
+ (remove-object (pointer object)))))
+ (let ((rank (get-conversion-sequence argument type nil)))
+ (if (null rank)
+ (let ((rank (get-conversion-sequence argument type t)))
+ (if (null rank)
+ (error "Can not convert the argument ~S to ~A."
+ argument (name type))
+ (let ((ret (funcall (conversion-function-name rank)
+ argument)))
+ (when (and disown (stack-p type))
+ (disown ret))
+ ret)))
+ (prog1 (funcall (conversion-function-name rank) argument)
+ (when (and disown (stack-p type))
+ (disown argument)))))))
(defun put-returnvalue (stack value type object)
(unless (void-p type)
(let ((stack (make-call-stack stack)))
(setf (call-stack-top stack) (call-stack-pointer stack))
- ;; FIXME support user conversions.
- ;;
- ;; We need to determine which of value and converted-value is
- ;; passed on the stack. E.g. converted-value can be something
- ;; like (cxx:operator-variant value).
- (let ((converted-value (convert-argument value type nil)))
- (push-smoke-stack stack converted-value (type-id type))
- (when (stack-p type) ;; Pass by value => smoke deletes the object.
- (remove-finalizer converted-value)
- (when (typep value 'smoke-standard-object)
- (remove-object (pointer value))))))))
- ; (transfer-ownership-to value object)))))))
+ (let ((converted-value (convert-argument value type t)))
+ (push-smoke-stack stack converted-value (type-id type))))))
(defun get-gf-for-method (smoke-method)
(declare (smoke-method smoke-method)
diff -rN -u old-smoke/src/object-map.lisp new-smoke/src/object-map.lisp
--- old-smoke/src/object-map.lisp 2014-10-30 07:05:47.000000000 +0100
+++ new-smoke/src/object-map.lisp 2014-10-30 07:05:47.000000000 +0100
@@ -112,7 +112,8 @@
(defun add-object (object)
"Adds OBJECT to the pointer -> object map. It can later be retrieved
with GET-OBJECT."
- (assert (not (has-pointer-p (pointer object))) ()
- "There exists already a object ~A for the pointer of ~A."
- (get-object (pointer object)) object)
+ (when (has-pointer-p (pointer object))
+ (cerror "Overwrite the old object."
+ "There exists already a object ~A for the pointer of ~A."
+ (get-object (pointer object)) object))
(setf (get-object (pointer object)) object))
diff -rN -u old-smoke/src/overload-resolution.lisp new-smoke/src/overload-resolution.lisp
--- old-smoke/src/overload-resolution.lisp 2014-10-30 07:05:47.000000000 +0100
+++ new-smoke/src/overload-resolution.lisp 2014-10-30 07:05:47.000000000 +0100
@@ -302,8 +302,10 @@
the function CONVERSION-FUNCTION-NAME."
`(progn ,@(loop for type-name in (ensure-list type-names)
collect `(setf (gethash ,type-name *from-lisp-translations*)
- #'(lambda (type)
- (and (subtypep type ',lisp-type)
+ #'(lambda (type type-p)
+ (and (if type-p
+ (subtypep type ',lisp-type)
+ (typep type ',lisp-type))
',conversion-function-name))))))
(define-from-lisp-translation ("void*" "const void*" "void**" "const void**")
@@ -323,7 +325,7 @@
"Test for an exact match."
(case (type-id type)
(0 (when-let (test (gethash (name type) *from-lisp-translations*))
- (funcall test (object.type-of))))
+ (funcall test object (using-typep))))
(1 (object.typep 'boolean))
(2 (object.typep 'standard-char))
(3 (object.typep '(c-integer :unsigned-char)))