More about exit hooks.

scsh/top.scm

@@ -319,7 +319,19 @@
 (define (parse-switches-and-execute all-args context)
   (receive (switches term-switch term-val top-entry args)
       (parse-scsh-args (cdr all-args))
-    (begin
+    (with-handler 
+     (lambda (cond more)
+       (if (warning? cond)
+	   (more)
+	   (with-handler
+	    (lambda (c m)
+	      (scheme-exit-now 1))
+	    (lambda ()
+	      (call-exit-hooks)
+	      (narrow (lambda ()
+			(call-narrowed-exit-hooks)))
+	      (more)))))
+     (lambda ()
        (with-scsh-initialized
 	(not term-switch) context args
 	(lambda ()
@@ -340,7 +352,7 @@
 			      (interaction-environment)))
 	   
 	    (cond ((not term-switch)	; -- interactive
-		  (exit 
+		   (scsh-exit-now
 		    (restart-command-processor 
 		     args 
 		     context 
@@ -359,19 +371,16 @@
 		  ((eq? term-switch 'c)
 		   (let ((result (eval (read-exactly-one-sexp-from-string term-val)
 				       (interaction-environment))))
-		    (call-exit-hooks)
-		    (scheme-exit-now 0)))
+		     (scsh-exit-now 0)))
 		 
 		  (top-entry		; There was a -e <entry>.
 		   (let ((result ((eval top-entry (interaction-environment))
 				  (command-line))))
-		    (call-exit-hooks)
-		    (scheme-exit-now 0)))
+		     (scsh-exit-now 0)))
 		 
 		  ;; Otherwise, the script executed as it loaded,
 		  ;; so we're done.
-		 (else (call-exit-hooks)
-		       (scheme-exit-now 0)))))))))
+		  (else (scsh-exit-now 0))))))))))
 
 
 (define (read-exactly-one-sexp-from-string s)
@@ -380,11 +389,25 @@
       (if (eof-object? (read)) val
 	  (error "More than one value read from string" s)))))
 
-;;; placeholder for an extensible mechanism in the future
+(define *exit-hooks* '())
+(define (add-exit-hook! thunk)
+  (set! *exit-hooks* (cons thunk *exit-hooks*)))
 (define (call-exit-hooks)
-  (flush-all-ports)
-  (relinquish-timeslice)
-  (relinquish-timeslice))
+  (for-each (lambda (thunk) (thunk)) *exit-hooks*))
+
+(define *narrowed-exit-hooks* '())
+(define (add-narrowed-exit-hook! thunk)
+  (set! *narrowed-exit-hooks* (cons thunk *narrowed-exit-hooks*)))
+(define (call-narrowed-exit-hooks)
+
+(define (scsh-exit-now status)
+  (call-exit-hooks)
+  (narrow
+   (lambda ()
+     (call-narrowed-exit-hooks)
+     (scheme-exit-now status))))
+
+(add-narrowed-exit-hook! flush-all-ports)
 
 (define (load-library-file file lib-dirs script-file)
 ; (format (error-output-port) "Load-library-file: ~a ~s\n" file lib-dirs)