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) (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
(with-scsh-initialized (lambda (cond more)
(not term-switch) context args (if (warning? cond)
(lambda () (more)
;; Have to do these before calling DO-SWITCHES, because actions (with-handler
;; performed while processing the switches may use these guys. (lambda (c m)
(set-command-line-args! (scheme-exit-now 1))
(cons (if (eq? term-switch 's) (lambda ()
(if (string? term-val) (call-exit-hooks)
term-val ; Script file. (narrow (lambda ()
"file-descriptor-script") ; -sfd <num> (call-narrowed-exit-hooks)))
(car all-args)) (more)))))
args)) (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))) (let* ((script-loaded? (do-switches switches term-val)))
(if (and (not script-loaded?) ; There wasn't a -ds or -dm, (if (and (not script-loaded?) ; There wasn't a -ds or -dm,
(eq? term-switch 's)) ; but there is a script, (eq? term-switch 's)) ; but there is a script,
(load-quietly term-val ; so load it now. (load-quietly term-val ; so load it now.
(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
(lambda () (lambda ()
(display (string-append (display (string-append
"Welcome to scsh " "Welcome to scsh "
scsh-version-string scsh-version-string
" (Gambit-C 4.0)") " (Gambit-C 4.0)")
(current-output-port)) (current-output-port))
(newline (current-output-port)) (newline (current-output-port))
(display "Type ,? for help." (display "Type ,? for help."
(current-output-port)) (current-output-port))
(newline (current-output-port)) (newline (current-output-port))
(in-package (user-environment) '()))))) (in-package (user-environment) '())))))
((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)