chicken-hackers
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Chicken-hackers] [PATCH] handle calls to exit in on-exit handlers


From: Felix
Subject: [Chicken-hackers] [PATCH] handle calls to exit in on-exit handlers
Date: Fri, 02 Aug 2013 14:29:51 +0200 (CEST)

Currently calling "exit" inside an "on-exit" handler will result
in an endless loop or similarly disastrous behaviour. This patch
is an attempt to fix it.


cheers,
felix
>From 95cd37998b8f3fff4b327906224ccbb9055c2bbd Mon Sep 17 00:00:00 2001
From: felix <address@hidden>
Date: Thu, 1 Aug 2013 16:51:31 +0200
Subject: [PATCH] Fixes "on-exit": previously calls to "exit" inside an
 on-exit handler would loop endlessly.

---
 library.scm |   47 +++++++++++++++++++++++++++--------------------
 1 file changed, 27 insertions(+), 20 deletions(-)

diff --git a/library.scm b/library.scm
index 7b5c61b..e01e868 100644
--- a/library.scm
+++ b/library.scm
@@ -34,6 +34,7 @@
        current-print-length setter-tag read-marks
        ##sys#print-exit
        ##sys#format-here-doc-warning
+       exit-in-progress
         maximal-string-length)
   (not inline ##sys#user-read-hook ##sys#error-hook ##sys#signal-hook 
##sys#schedule
        ##sys#default-read-info-hook ##sys#infix-list-hook 
##sys#sharp-number-hook
@@ -3957,17 +3958,17 @@ EOF
    (lambda ()
      ((##sys#exit-handler) _ex_software)) ) )
 
+(define exit-in-progress #f)
+
 (define exit-handler
   (make-parameter
-   (lambda code
-     (##sys#cleanup-before-exit)
-     (##core#inline
-      "C_exit_runtime"
-      (if (null? code)
-         0
-         (let ([code (car code)])
-           (##sys#check-exact code)
-           code) ) ) ) ) )
+   (lambda (#!optional (code 0))
+     (##sys#check-exact code)
+     (cond (exit-in-progress
+           (##sys#warn "\"exit\" called while processing on-exit tasks"))
+          (else
+           (##sys#cleanup-before-exit)
+           (##core#inline "C_exit_runtime" code))))))
 
 (define implicit-exit-handler
   (make-parameter
@@ -3980,19 +3981,25 @@ EOF
 
 (define force-finalizers (make-parameter #t))
 
-(define ##sys#cleanup-before-exit
-  (lambda ()
-    (when (##sys#fudge 37)
-      (##sys#print "\n" #f ##sys#standard-error)
-      (##sys#dump-heap-state))
-    (when (##sys#fudge 13)
-      (##sys#print "[debug] forcing finalizers...\n" #f ##sys#standard-error) )
-    (when (force-finalizers) (##sys#force-finalizers)) ) )
+(define ##sys#cleanup-tasks '())
+
+(define (##sys#cleanup-before-exit)
+  (set! exit-in-progress #t)
+  (when (##sys#fudge 37)               ; -:H given?
+    (##sys#print "\n" #f ##sys#standard-error)
+    (##sys#dump-heap-state))
+  (let loop ()
+    (let ((tasks ##sys#cleanup-tasks))
+      (set! ##sys#cleanup-tasks '())
+      (unless (null? tasks)
+       (for-each (lambda (t) (t)) tasks)
+       (loop))))    
+  (when (##sys#fudge 13)               ; debug mode
+    (##sys#print "[debug] forcing finalizers...\n" #f ##sys#standard-error) )
+  (when (force-finalizers) (##sys#force-finalizers)) )
 
 (define (on-exit thunk)
-  (set! ##sys#cleanup-before-exit
-    (let ((old ##sys#cleanup-before-exit))
-      (lambda () (old) (thunk)) ) ) )
+  (set! ##sys#cleanup-tasks (cons thunk ##sys#cleanup-tasks)))
 
 
 ;;; Condition handling:
-- 
1.7.9.5


reply via email to

[Prev in Thread] Current Thread [Next in Thread]