~ chicken-core (chicken-5) 8a6d9a46185f4ae0498792840a5ebda659eaed61
commit 8a6d9a46185f4ae0498792840a5ebda659eaed61
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jun 22 17:20:47 2012 +0200
Commit: Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sat Jun 23 14:43:18 2012 +0200
Exceptions signalled by code that executes in finalizers will now be caught and do not propagate upwards into arbitrary user code.
Signed-off-by: Peter Bex <peter.bex@xs4all.nl>
diff --git a/distribution/manifest b/distribution/manifest
index d4b641b9..b71da353 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -190,6 +190,7 @@ tests/functor-tests.scm
tests/square-functor.scm
tests/use-square-functor.scm
tests/pp-test.scm
+tests/finalizer-error-test.scm
tests/reverser/tags/1.0/reverser.meta
tests/reverser/tags/1.0/reverser.setup
tests/reverser/tags/1.0/reverser.scm
diff --git a/library.scm b/library.scm
index 030fad80..90d22c63 100644
--- a/library.scm
+++ b/library.scm
@@ -4601,8 +4601,10 @@ EOF
(do ([i 0 (fx+ i 1)])
((fx>= i c))
(let ([i2 (fx+ 1 (fx* i 2))])
- ((##sys#slot ##sys#pending-finalizers (fx+ i2 1))
- (##sys#slot ##sys#pending-finalizers i2)) ) )
+ (handle-exceptions ex
+ (##sys#show-exception-warning ex "in finalizer" #f)
+ ((##sys#slot ##sys#pending-finalizers (fx+ i2 1))
+ (##sys#slot ##sys#pending-finalizers i2)) ) ))
(vector-fill! ##sys#pending-finalizers (##core#undefined))
(##sys#setislot ##sys#pending-finalizers 0 0)
(set! working #f) ) )
@@ -4741,6 +4743,30 @@ EOF
(writeargs (list ex) port) ] ) ) ) ) )
+;;; Show exception message and backtrace as warning
+;;; (used for threads and finalizers)
+
+(define ##sys#show-exception-warning
+ (let ((print-error-message print-error-message)
+ (display display)
+ (write-char write-char)
+ (print-call-chain print-call-chain)
+ (open-output-string open-output-string)
+ (get-output-string get-output-string) )
+ (lambda (exn cause #!optional (thread ##sys#current-thread))
+ (when ##sys#warnings-enabled
+ (let ((o (open-output-string)))
+ (display "Warning" o)
+ (when thread
+ (display " (" o)
+ (display thread o)
+ (write-char #\) o))
+ (display ": " o)
+ (display cause o)
+ (print-error-message exn ##sys#standard-error (get-output-string o))
+ (print-call-chain ##sys#standard-error 0 thread) ) ))))
+
+
;;; We need this here so `location' works:
(define (##sys#make-locative obj index weak? loc)
diff --git a/scheduler.scm b/scheduler.scm
index e3a96bc1..d3a2620f 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -309,35 +309,24 @@ EOF
(##sys#setislot t 4 #f)
(##sys#add-to-ready-queue t) )
-(define ##sys#default-exception-handler
- (let ([print-error-message print-error-message]
- [display display]
- [print-call-chain print-call-chain]
- [open-output-string open-output-string]
- [get-output-string get-output-string] )
- (lambda (arg)
- (let ([ct ##sys#current-thread])
- (dbg "exception: " ct " -> "
- (if (##sys#structure? arg 'condition) (##sys#slot arg 2) arg))
- (cond [(foreign-value "C_abort_on_thread_exceptions" bool)
- (let* ([pt ##sys#primordial-thread]
- [ptx (##sys#slot pt 1)] )
- (##sys#setslot
- pt 1
- (lambda ()
- (##sys#signal arg)
- (ptx) ) )
- (##sys#thread-unblock! pt) ) ]
- [##sys#warnings-enabled
- (let ([o (open-output-string)])
- (display "Warning (" o)
- (display ct o)
- (display ")" o)
- (print-error-message arg ##sys#standard-error (get-output-string o))
- (print-call-chain ##sys#standard-error 0 ct) ) ] )
- (##sys#setslot ct 7 arg)
- (##sys#thread-kill! ct 'terminated)
- (##sys#schedule) ) ) ) )
+(define (##sys#default-exception-handler arg)
+ (let ([ct ##sys#current-thread])
+ (dbg "exception: " ct " -> "
+ (if (##sys#structure? arg 'condition) (##sys#slot arg 2) arg))
+ (cond ((foreign-value "C_abort_on_thread_exceptions" bool)
+ (let* ([pt ##sys#primordial-thread]
+ [ptx (##sys#slot pt 1)] )
+ (##sys#setslot
+ pt 1
+ (lambda ()
+ (##sys#signal arg)
+ (ptx) ) )
+ (##sys#thread-unblock! pt) ) )
+ (else
+ (##sys#show-exception-warning arg "in thread" ct)))
+ (##sys#setslot ct 7 arg)
+ (##sys#thread-kill! ct 'terminated)
+ (##sys#schedule) ) )
;;; `select()'-based blocking:
diff --git a/tests/runtests.sh b/tests/runtests.sh
index d21b7044..63790ef5 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -344,8 +344,8 @@ $compile symbolgc-tests.scm
echo "======================================== finalizer tests ..."
$interpret -s test-finalizers.scm
-
-echo "======================================== finalizer tests (2) ..."
+$compile finalizer-error-test.scm
+./a.out
$compile test-finalizers-2.scm
./a.out
Trap