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 - (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 + (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 . - (let ((result ((eval top-entry (interaction-environment)) - (command-line)))) - (call-exit-hooks) - (scheme-exit-now 0))) + (top-entry ; There was a -e . + (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)