scsh-0.6/scsh/top.scm

350 lines
11 KiB
Scheme

;;; The scsh argv switch parser.
;;; Copyright (c) 1995 by Olin Shivers. See file COPYING.
;;; Imports:
;;; COMMAND-PROCESSOR: set-batch-mode?! command-loop
;;; ENSURES-LOADED: really-ensure-loaded
;;; ENVIRONMENTS: set-interaction-environment! environment-ref
;;; environment-define!
;;; ERROR-PACKAGE: error
;;; EVALUATION: eval
;;; EXTENDED-PORTS: make-string-input-port
;;; INTERFACES: make-simple-interface
;;; INTERRUPTS: interrupt-before-heap-overflow!
;;; PACKAGE-COMMANDS-INTERNAL: user-environment config-package
;;; get-reflective-tower
;;; PACKAGE-MUTATION: package-open!
;;; PACKAGES: structure-package structure? make-structure
;;; make-simple-package
;;; RECEIVING: mv return stuff
;;; SCSH-LEVEL-0-INTERNALS: set-command-line-args!
;;; SCSH-VERSION: scsh-version-string
;;;
;;; This should be defined by the package code, but it isn't.
(define (get-struct config-pack struct-name)
(let ((s (environment-ref config-pack struct-name)))
(cond ((structure? s) s)
(else (error "not a structure" s struct-name)))))
;;; The switches:
;;; -o <struct> Open the structure in current package.
;;; -n <package> Create new package, make it current package.
;;; -m <struct> <struct>'s package becomes current package.
;;;
;;; -l <file> Load <file> into current package.
;;; -lm <file> Load <file> into config package.
;;;
;;; These two require a terminating -s or -sfd arg:
;;; -ds Load terminating script into current package.
;;; -dm Load terminating script into config package.
;;;
;;; -e <entry> Call (<entry>) to start program.
;;;
;;; Terminating switches:
;;; -c <exp> Eval <exp>, then exit.
;;; -s <script> Specify <script> to be loaded by a -ds or -dm.
;;; -sfd <num> Script is on file descriptor <num>.
;;; -- Interactive scsh.
;;; Return switch list, terminating switch, with arg, top-entry,
;;; and command-line args.
;;; - We first expand out any initial \ <filename> meta-arg.
;;; - A switch-list elt is either "-ds", "-dm", or a (switch . arg) pair
;;; for a -o, -n, -m, -l, or -lm switch.
;;; - Terminating switch is one of {s, c, #f} for -s or -sfd, -c,
;;; and -- respectively.
;;; - Terminating arg is the <exp> arg to -c, the <script> arg to -s,
;;; the input port for -sfd, otw #f.
;;; - top-entry is the <entry> arg to a -e; #f if none.
;;; - command-line args are what's left over after picking off the scsh
;;; switches.
(define (parse-scsh-args args)
(let lp ((args (meta-arg-process-arglist args))
(switches '()) ; A list of handler thunks
(top-entry #f) ; -t <entry>
(need-script? #f)) ; Found a -ds or -dm?
(if (pair? args)
(let ((arg (car args))
(args (cdr args)))
(cond ((string=? arg "-c")
(if (or need-script? top-entry (not (pair? args)))
(bad-arg)
(values (reverse switches) 'c (car args)
top-entry (cdr args))))
((string=? arg "-s")
(if (not (pair? args))
(bad-arg "-s switch requires argument")
(values (reverse switches) 's (car args)
top-entry (cdr args))))
;; -sfd <num>
((string=? arg "-sfd")
(if (not (pair? args))
(bad-arg "-sfd switch requires argument")
(let* ((fd (string->number (car args)))
(p (fdes->inport fd)))
(release-port-handle p) ; Unreveal the port.
(values (reverse switches) 's p
top-entry (cdr args)))))
((string=? arg "--")
(if need-script?
(bad-arg "-ds or -dm switch requires -s <script>")
(values (reverse switches) #f #f top-entry args)))
((or (string=? arg "-ds")
(string=? arg "-dm"))
(lp args (cons arg switches) top-entry #t))
((or (string=? arg "-l")
(string=? arg "-lm"))
(if (pair? args)
(lp (cdr args)
(cons (cons arg (car args)) switches)
top-entry
need-script?)
(bad-arg "Switch requires argument" arg)))
((or (string=? arg "-o")
(string=? arg "-n")
(string=? arg "-m"))
(if (pair? args)
(let* ((s (car args))
(name (if (and (string=? arg "-n")
(string=? s "#f"))
#f ; -n #f treated specially.
(string->symbol s))))
(lp (cdr args)
(cons (cons arg name) switches)
top-entry
need-script?))
(bad-arg "Switch requires argument" arg)))
((string=? arg "-e")
(lp (cdr args) switches
(string->symbol (car args)) need-script?))
(else (bad-arg "Unknown switch" arg))))
(values (reverse switches) #f #f top-entry '()))))
;;; Do each -ds, -dm, -o, -n, -m, -l, and -lm switch, and return the final
;;; result package and a flag saying if the script was loaded by a -ds or -dm.
(define (do-switches switches script-file)
; (format #t "Switches = ~a~%" switches)
(let lp ((switches switches)
(script-loaded? #f))
(if (pair? switches)
(let ((switch (car switches))
(switches (cdr switches)))
; (format #t "Doing switch ~a~%" switch)
(cond
((equal? switch "-ds")
(load-quietly script-file (interaction-environment))
; (format #t "loaded script ~s~%" script-file)
(lp switches #t))
((equal? switch "-dm")
(load-quietly script-file (config-package))
; (format #t "loaded module ~s~%" script-file)
(lp switches #t))
((string=? (car switch) "-l")
; (format #t "loading file ~s~%" (cdr switch))
(load-quietly (cdr switch) (interaction-environment))
(lp switches script-loaded?))
((string=? (car switch) "-lm")
; (format #t "loading module file ~s~%" (cdr switch))
(load-quietly (cdr switch) (config-package))
(lp switches script-loaded?))
((string=? (car switch) "-o")
(let ((struct-name (cdr switch))
(cp (config-package)))
;; Should not be necessary to do this ensure-loaded, but it is.
(really-ensure-loaded #f (get-struct cp struct-name))
(package-open! (interaction-environment)
(lambda () (get-struct cp struct-name)))
; (format #t "Opened ~s~%" struct-name)
(lp switches script-loaded?)))
((string=? (car switch) "-n")
(let* ((name (cdr switch))
(pack (new-empty-package name))) ; Contains nothing
(if name ; & exports nothing.
(let* ((iface (make-simple-interface #f '()))
(struct (make-structure pack iface)))
(environment-define! (config-package) name struct)))
(set-interaction-environment! pack)
(lp switches script-loaded?)))
((string=? (car switch) "-m")
; (format #t "struct-name ~s~%" (cdr switch))
(let ((struct (get-struct (config-package) (cdr switch))))
; (format #t "struct-name ~s, struct ~s~%" (cdr switch) struct)
(let ((pack (structure-package struct)))
; (format #t "package ~s~%" pack)
(set-interaction-environment! pack)
(really-ensure-loaded #f struct)
; (format #t "Switched to ~s~%" pack)
(lp switches script-loaded?))))
(else (error "Impossible error in do-switches. Report to developers."))))
script-loaded?)))
;;; (user-environment) probably isn't right. What is this g-r-t stuff?
;;; Check w/jar.
(define (new-empty-package name)
(make-simple-package '() #t
(get-reflective-tower (user-environment)) ; ???
name))
(define (parse-switches-and-execute all-args context)
(receive (switches term-switch term-val top-entry args)
(parse-scsh-args (cdr all-args))
(begin
(display "hey there.." (current-error-port))
; (display context (current-error-port))
; (display (config-package))
; (display (user-environment))
((with-handler ; taken from command.scm
command-loop-condition-handler
(lambda ()
(notify-on-interrupts (current-thread))
(start-new-session context
(current-input-port)
(current-output-port)
(current-error-port)
args
term-switch)
(display "bye" (current-error-port))
(display (config-package) (current-error-port))
(display "ups" (current-error-port))
; (let ((commands usual-commands)
; (build-in built-in-structures)
; (meta-structs more-structures))
; (call-with-values
; (lambda ()
; (make-user-envs commands build-in meta-structs))
; (lambda (env init-thunk)
(with-interaction-environment
(user-environment)
(display "okay, but now ?" (current-error-port))
(begin
;(with-interaction-environment (user-environment) ; <-- from CONTEXT.
(begin
;; 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))
;; Set HOME-DIRECTORY and EXEC-PATH-LIST,
;; quietly if not running an interactive script.
(init-scsh-vars term-switch)
(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
(display "scsh is up" (current-error-port))
(init-scsh-vars #t)
(display "fdports installed" (current-error-port))
; (interrupt-before-heap-overflow!)
(let ((repl-data #f) ;no condition
(repl-thunk real-command-loop))
(let ((thunk (really-push-command-level repl-thunk
repl-data
(get-dynamic-env)
'())))
(ignore-further-interrupts)
thunk)))
;
(command-loop
;(lambda ()
; (display "Scsh ")
; (display scsh-version-string)
; (newline))
; #f))
;; COMMAND-LOOP returns a continuation when it exits,
;; which gets invoked outside the W-N-S above. I.e.,
;; we "log out" and start over.
((eq? term-switch 'c)
;;; JMG eval now needs expr represented as data
(eval '(read-exactly-one-sexp-from-string term-val)
(interaction-environment))
(exit 0))
(top-entry ; There was a -e <entry>.
((eval top-entry (interaction-environment))
(command-line))
(exit 0))
;; Otherwise, the script executed as it loaded,
;; so we're done.
(else (exit 0))
))))))))))))
(define (read-exactly-one-sexp-from-string s)
(with-current-input-port (make-string-input-port s)
(let ((val (read)))
(if (eof-object? (read)) val
(error "More than one value read from string" s)))))
(define (bad-arg . msg)
(with-current-output-port (current-error-port)
(for-each (lambda (x) (display x) (write-char #\space)) msg)
(newline)
(display "Useage: scsh [meta-arg] [switch ..] [end-option arg ...]
meta-arg: \\ <script-file-name>
switch: -e <entry-point> Specify top-level entry point.
-o <structure> Open structure in current package.
-m <package> Switch to package.
-n <new-package> Switch to new package.
-lm <module-file-name> Load module into config package.
-l <file-name> Load file into current package.
-ds Do script.
-dm Do script module.
end-option: -s <script> Specify script.
-sfd <num> Script is on file descriptor <num>.
-c <exp> Evaluate expression.
-- Interactive session.
"))
(exit -1))
(define (repl)
(command-loop (lambda () (set-batch-mode?! #f))
#f))