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

127
scsh/top.scm
View File

@ -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)