scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

More about exit hooks.

This commit is contained in:
mainzelm 2002-06-26 11:18:25 +00:00
parent 71e3326079
commit 4e295e26d1
1 changed files with 75 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
scsh/top.scm
View File

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