Wed Jun 3 23:55:26 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Added restarts to method dispatch callback.
diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp
--- old-smoke/src/clos.lisp 2014-09-30 10:29:30.000000000 +0200
+++ new-smoke/src/clos.lisp 2014-09-30 10:29:31.000000000 +0200
@@ -308,29 +308,65 @@
(stack smoke-stack)
(abstract :boolean))
(declare (optimize (speed 3)))
- (let ((method (make-instance 'smoke-method
- :id method
- :smoke (smoke-get-smoke binding))))
- (let ((gf (get-gf-for-method method)))
- (if (null (gf-methods gf))
- (progn
- (when abstract
- (error "Abstract method ~S called." (name method)))
- nil)
- (let ((object (get-object object)))
- (if object
- (progn
- (put-returnvalue
- stack
- (apply gf object
- (stack-to-args
- (cffi:inc-pointer stack
- (cffi:foreign-type-size
- 'smoke-stack-item))
- (get-first-argument method)))
- (return-type method))
- t)
- nil))))))
+ (let* ((method (make-instance 'smoke-method
+ :id method
+ :smoke (smoke-get-smoke binding))))
+ (loop
+ (restart-case
+ (return-from dispatch-method
+ (let ((gf (get-gf-for-method method)))
+ (if (null (gf-methods gf))
+ (progn
+ (when abstract
+ (error "Abstract method ~A called."
+ (method-declaration method)))
+ nil)
+ (let ((object (get-object object)))
+ (if object
+ (progn
+ (put-returnvalue
+ stack
+ (apply gf object
+ (stack-to-args
+ (cffi:inc-pointer stack
+ (cffi:foreign-type-size
+ 'smoke-stack-item))
+ (get-first-argument method)))
+ (return-type method))
+ t)
+ nil)))))
+ (call-default ()
+ :report (lambda (stream)
+ (format stream "Call default implementation ~A instead."
+ method))
+ :test (lambda (condition)
+ (declare (ignore condition))
+ (not abstract))
+ (return-from dispatch-method nil))
+ (use-returnvalue (return-value)
+ :report (lambda (stream)
+ (format stream "Supply a return value for ~A."
+ (method-declaration method)))
+ :test (lambda (condition)
+ (declare (ignore condition))
+ (not (void-p (return-type method))))
+ :interactive (lambda ()
+ (format *query-io* "~&Enter a new return value: ")
+ (multiple-value-list (eval (read *query-io*))))
+ (put-returnvalue stack return-value (return-type method))
+ (return-from dispatch-method t))
+ (return ()
+ :report (lambda (stream)
+ (format stream "Return void for ~A."
+ (method-declaration method)))
+ :test (lambda (condition)
+ (declare (ignore condition))
+ (void-p (return-type method)))
+ (return-from dispatch-method (values)))
+ (retry ()
+ :report (lambda (stream)
+ (format stream "Try again calling ~A"
+ (method-declaration method))))))))
;;FIXME use CHANGE-CLASS instead?
(defun cast (object class)
diff -rN -u old-smoke/src/object-map.lisp new-smoke/src/object-map.lisp
--- old-smoke/src/object-map.lisp 2014-09-30 10:29:30.000000000 +0200
+++ new-smoke/src/object-map.lisp 2014-09-30 10:29:31.000000000 +0200
@@ -52,9 +52,11 @@
"No object to remove for pointer ~A." pointer)
(remhash (pointer-address pointer) *object-map*))
-(defun report-finalize-error (condition function object pointer)
- (warn "error calling finalizer ~A for ~A ~A:~%~5T~A"
- function object pointer condition))
+(defun report-finalize-error (condition function class pointer)
+ "Report the error CONDITION it the finalizer FUNCTION for the
+object at POINTER of class CLASS."
+ (warn "error calling finalizer ~A for ~A ~A:~%~5T~A~%"
+ function class pointer condition))
(defgeneric make-finalize (object)
(:documentation "Returns a function to be called when OBJECT is finalized."))
diff -rN -u old-smoke/src/objects/method.lisp new-smoke/src/objects/method.lisp
--- old-smoke/src/objects/method.lisp 2014-09-30 10:29:30.000000000 +0200
+++ new-smoke/src/objects/method.lisp 2014-09-30 10:29:31.000000000 +0200
@@ -226,4 +226,3 @@
(defun arguments (method)
"Returns a list of the arguments of METHOD."
(build-argument-list nil (get-first-argument method)))
-
diff -rN -u old-smoke/src/smoke-c/csmokebinding.cpp new-smoke/src/smoke-c/csmokebinding.cpp
--- old-smoke/src/smoke-c/csmokebinding.cpp 2014-09-30 10:29:30.000000000 +0200
+++ new-smoke/src/smoke-c/csmokebinding.cpp 2014-09-30 10:29:31.000000000 +0200
@@ -55,12 +55,15 @@
destruct(this, classId, obj);
}
-/** Invoked whne a Smoke method gets called. */
+/** Invoked when a Smoke method gets called. */
bool
Binding::callMethod(Smoke::Index method, void* object,
Smoke::Stack stack, bool abstract)
{
- return dispatch(this, method, object, stack, abstract);
+ int ret = dispatch(this, method, object, stack, abstract);
+ Q_ASSERT( !abstract || ret );
+
+ return ret;
}
/**
diff -rN -u old-smoke/src/smoke-c/smoke-c.cpp new-smoke/src/smoke-c/smoke-c.cpp
--- old-smoke/src/smoke-c/smoke-c.cpp 2014-09-30 10:29:30.000000000 +0200
+++ new-smoke/src/smoke-c/smoke-c.cpp 2014-09-30 10:29:30.000000000 +0200
@@ -3,7 +3,6 @@
#include <smoke.h>
-#include <stdexcept>
#include <QtGlobal>
/** @file
@@ -323,11 +322,13 @@
{
Q_ASSERT(klass->classFn != NULL);
(*klass->classFn)(meth.method, object, stack);
- }
- catch (std::exception& e)
+ }
+ // This catch is mostly useless:
+ // Qt / KDElibs do not use exceptions and since they are often built with -fno-exceptions
+ // the catch will have no effect and the terminate handler is called instead.
+ catch (const std::exception& e)
{
qFatal(e.what());
- return;
}
catch (...)
{
diff -rN -u old-smoke/src/smoke-c/smoke-c.lisp new-smoke/src/smoke-c/smoke-c.lisp
--- old-smoke/src/smoke-c/smoke-c.lisp 2014-09-30 10:29:30.000000000 +0200
+++ new-smoke/src/smoke-c/smoke-c.lisp 2014-09-30 10:29:31.000000000 +0200
@@ -58,7 +58,6 @@
(smoke :pointer)
(index smoke-index))
-
(defcfun smoke-set-binding :void
"Sets the binding for an newly constructed instance."
(smoke :pointer)