scsh-0.5/scsh/top.scm

;;; The scsh argv switch parser.
;;; Copyright (c) 1995 by Olin Shivers.

;;; 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 terminating -s <script> 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.
;;;	-s<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 -s<num>, -c, 
;;;   and -- respectively.
;;; - Terminating arg is the <exp> arg to -c, the <script> arg to -s, 
;;;   the input port for -s<num>, 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))))

		;; -s<num>
		((regexp-exec fd-script-regexp arg) =>
		 (lambda (m)
		   (let* ((fd (string->number (match:substring m 1) 10))
			  (p (fdes->inport fd)))
		     (release-port-handle p)	; Unreveal the port.
		     (values (reverse switches)
			     's
			     (fdes->inport fd)
			     top-entry 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 '()))))

(define fd-script-regexp (make-regexp "^-s([0-9]+)$"))

;;; 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))
    ((with-new-session context	; "Log in" user.
		      (current-input-port) (current-output-port)
		      args
		      term-switch	; batch? (or interactive?)
       (lambda ()
	 (with-interaction-environment (user-environment) ; <-- from CONTEXT.
           (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"); -s<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
		      (interrupt-before-heap-overflow!)
		      (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)
		      (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 (error-output-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.
		-s<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))