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

Revert last check-in. Reading again through the manual, I now think that it's maybe better to complain if -e was specified without -sfd or -s.

This commit is contained in:
mainzelm 2004-02-20 15:27:29 +00:00
parent 388d2f7b2b
commit 90ba284584
1 changed files with 78 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

175
scsh/top.scm
View File

@ -107,7 +107,7 @@
(define (parse-scsh-args args) (define (parse-scsh-args args)
(let lp ((args (meta-arg-process-arglist args)) (let lp ((args (meta-arg-process-arglist args))
(switches '()) ; A list of handler thunks (switches '()) ; A list of handler thunks
(top-entry #f) ; -e <entry> (top-entry #f) ; -t <entry>
(need-script? #f)) ; Found a -ds, -dm, or -de? (need-script? #f)) ; Found a -ds, -dm, or -de?
; (display args (current-output-port)) ; (display args (current-output-port))
(if (pair? args) (if (pair? args)
@ -115,47 +115,31 @@
(args (cdr args))) (args (cdr args)))
(cond ((string=? arg "-c") (cond ((string=? arg "-c")
(cond ((not (pair? args)) (if (or need-script? top-entry (not (pair? args)))
(bad-arg "-c switch requires argument")) (bad-arg)
(top-entry (values (reverse switches) 'c (car args)
(bad-arg "-c switch used with -e switch")) top-entry (cdr args))))
(need-script?
(bad-arg "-ds, -dm, or -de switch requires -s <script>"))
(else
(values (reverse switches) 'c (car args)
top-entry (cdr args)))))
((string=? arg "-s") ((string=? arg "-s")
(cond ((not (pair? args)) (if (not (pair? args))
(bad-arg "-s switch requires argument")) (bad-arg "-s switch requires argument")
(top-entry (values (reverse switches) 's (car args)
(bad-arg "-s switch used with -e switch")) top-entry (cdr args))))
(need-script?
(bad-arg "-ds, -dm, or -de switch requires -s <script>"))
(else
(values (reverse switches) 's (car args)
top-entry (cdr args)))))
;; -sfd <num> ;; -sfd <num>
((string=? arg "-sfd") ((string=? arg "-sfd")
(cond ((not (pair? args)) (if (not (pair? args))
(bad-arg "-sfd switch requires argument")) (bad-arg "-sfd switch requires argument")
(top-entry (let* ((fd (string->number (car args)))
(bad-arg "-sdf switch used with -e switch")) (p (fdes->inport fd)))
(else (release-port-handle p) ; Unreveal the port.
(let* ((fd (string->number (car args))) (values (reverse switches) 'sfd p
(p (fdes->inport fd))) top-entry (cdr args)))))
(release-port-handle p) ; Unreveal the port.
(values (reverse switches) 'sfd p
top-entry (cdr args))))))
((string=? arg "--") ((string=? arg "--")
(cond (need-script? (if need-script?
(bad-arg "-ds, -dm, or -de switch requires -s <script>")) (bad-arg "-ds, -dm, or -de switch requires -s <script>")
(top-entry (values (reverse switches) #f #f top-entry args)))
(bad-arg "-- switch used with -e switch"))
(else
(values (reverse switches) #f #f top-entry args))))
((or (string=? arg "-ds") ((or (string=? arg "-ds")
(string=? arg "-dm") (string=? arg "-dm")
@ -202,10 +186,8 @@
(string->symbol (car args)) need-script?)) (string->symbol (car args)) need-script?))
(else (bad-arg "Unknown switch" arg)))) (else (bad-arg "Unknown switch" arg))))
(cond (need-script?
(bad-arg "-ds, -dm, or -de switch requires -s <script>")) (values (reverse switches) #f #f top-entry '()))))
(else
(values (reverse switches) #f #f top-entry '()))))))
;;; Do each -ds, -dm, -de, -o, -n, -m, -l/lm/ll, +lp/+lpe/lp+/lpe+, or ;;; Do each -ds, -dm, -de, -o, -n, -m, -l/lm/ll, +lp/+lpe/lp+/lpe+, or
;;; -lp-clear/lp-default switch, and return the final result package and a ;;; -lp-clear/lp-default switch, and return the final result package and a
@ -359,69 +341,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))
(let ((interactive? (not (or term-switch top-entry)))) (with-handler
(with-handler (lambda (cond more)
(lambda (cond more) (if (warning? cond)
(if (warning? cond) (more)
(more) (with-handler
(with-handler (lambda (c m)
(lambda (c m) (scheme-exit-now 1))
(scheme-exit-now 1)) (lambda ()
(lambda () (call-exit-hooks-and-narrow (lambda () #t))
(call-exit-hooks-and-narrow (lambda () #t)) (more)))))
(more))))) (lambda ()
(lambda () (with-scsh-initialized
(with-scsh-initialized (not term-switch) context args
interactive? context args (lambda ()
(lambda () ;; Have to do these before calling DO-SWITCHES, because actions
;; Have to do these before calling DO-SWITCHES, because actions ;; performed while processing the switches may use these guys.
;; performed while processing the switches may use these guys. (set-command-line-args!
(set-command-line-args! (cons (if (eq? term-switch 's)
(cons (if (eq? term-switch 's) term-val ; Script file.
term-val ; Script file. (if (eq? term-val 'sfd)
(if (eq? term-val 'sfd) "file-descriptor-script" ; -sfd <num>
"file-descriptor-script" ; -sfd <num> (car all-args)))
(car all-args))) args))
args))
(let* ((script-loaded? (do-switches switches term-val))) (let* ((script-loaded? (do-switches switches term-val)))
(if (not script-loaded?) ; There wasn't a -ds, -dm, or -de, (if (not script-loaded?) ; There wasn't a -ds, -dm, or -de,
(if (eq? term-switch 's) ; but there is a script, (if (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))
(if (eq? term-switch 'sfd) (if (eq? term-switch 'sfd)
(load-port-quietly term-val (interaction-environment))))) (load-port-quietly term-val (interaction-environment)))))
(cond (interactive? (cond ((not term-switch) ; -- interactive
(scsh-exit-now ;; TODO: ,exit will bypass this (scsh-exit-now ;; TODO: ,exit will bypass this
(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
" (" scsh-release-name ")") " (" scsh-release-name ")")
(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))))
(scsh-exit-now 0))) (scsh-exit-now 0)))
(top-entry ; There was a -e <entry>. (top-entry ; There was a -e <entry>.
((eval top-entry (interaction-environment)) ((eval top-entry (interaction-environment))
(command-line)) (command-line))
(scsh-exit-now 0)) (scsh-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 (scsh-exit-now 0))))))))))) (else (scsh-exit-now 0))))))))))
(define (read-exactly-one-sexp-from-string s) (define (read-exactly-one-sexp-from-string s)