From 4e295e26d178ce48acfe235e29562bf20357a18b Mon Sep 17 00:00:00 2001
From: mainzelm <mainzelm>
Date: Wed, 26 Jun 2002 11:18:25 +0000
Subject: [PATCH] More about exit hooks.

---
 scsh/top.scm | 127 ++++++++++++++++++++++++++++++---------------------
 1 file changed, 75 insertions(+), 52 deletions(-)

diff --git a/scsh/top.scm b/scsh/top.scm
index a3e5135..6ff2d0c 100644
--- a/scsh/top.scm
+++ b/scsh/top.scm
@@ -319,59 +319,68 @@
 (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-scsh-initialized
-       (not term-switch) context args
-       (lambda ()
-	 ;; Have to do these before calling DO-SWITCHES, because actions
-	 ;; performed while processing the switches may use these guys.
-	 (set-command-line-args!
-	  (cons (if (eq? term-switch 's)
-		    (if (string? term-val)
-			term-val	; Script file.
-			"file-descriptor-script") ; -sfd <num>
-		    (car all-args))
-		args))
+    (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 ()
+	  ;; Have to do these before calling DO-SWITCHES, because actions
+	  ;; performed while processing the switches may use these guys.
+	  (set-command-line-args!
+	   (cons (if (eq? term-switch 's)
+		     (if (string? term-val)
+			 term-val	; Script file.
+			 "file-descriptor-script") ; -sfd <num>
+		     (car all-args))
+		 args))
 	 
-	 (let* ((script-loaded?  (do-switches switches term-val)))
-	   (if (and (not script-loaded?) ; There wasn't a -ds or -dm,
-		    (eq? term-switch 's)) ; but there is a script,
-	       (load-quietly term-val	; so load it now.
-			     (interaction-environment)))
+	  (let* ((script-loaded?  (do-switches switches term-val)))
+	    (if (and (not script-loaded?) ; There wasn't a -ds or -dm,
+		     (eq? term-switch 's)) ; but there is a script,
+		(load-quietly term-val	; so load it now.
+			      (interaction-environment)))
 	   
-	   (cond ((not term-switch)	; -- interactive
-		  (exit 
-		   (restart-command-processor 
-		    args 
-		    context 
-		    (lambda () 
-		      (display (string-append 
-				"Welcome to scsh "
-				scsh-version-string
-				" (Gambit-C 4.0)")
-			       (current-output-port))
-		      (newline (current-output-port))
-		      (display "Type ,? for help."
-			       (current-output-port))
-		      (newline (current-output-port))
-		      (in-package (user-environment) '())))))
+	    (cond ((not term-switch)	; -- interactive
+		   (scsh-exit-now
+		    (restart-command-processor 
+		     args 
+		     context 
+		     (lambda () 
+		       (display (string-append 
+				 "Welcome to scsh "
+				 scsh-version-string
+				 " (Gambit-C 4.0)")
+				(current-output-port))
+		       (newline (current-output-port))
+		       (display "Type ,? for help."
+				(current-output-port))
+		       (newline (current-output-port))
+		       (in-package (user-environment) '())))))
 
-		 ((eq? term-switch 'c)
-		  (let ((result (eval (read-exactly-one-sexp-from-string term-val)
-				      (interaction-environment))))
-		    (call-exit-hooks)
-		    (scheme-exit-now 0)))
+		  ((eq? term-switch 'c)
+		   (let ((result (eval (read-exactly-one-sexp-from-string term-val)
+				       (interaction-environment))))
+		     (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)))
+		  (top-entry		; There was a -e <entry>.
+		   (let ((result ((eval top-entry (interaction-environment))
+				  (command-line))))
+		     (scsh-exit-now 0)))
 		 
-		 ;; Otherwise, the script executed as it loaded,
-		 ;; so we're done.
-		 (else (call-exit-hooks)
-		       (scheme-exit-now 0)))))))))
+		  ;; Otherwise, the script executed as it loaded,
+		  ;; so we're done.
+		  (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)