scsh-0.5/scsh/oldtop.scm

;;; Scsh top level
;;; Copyright (c) 1993 by Olin Shivers.

;;; Requires
;;;   From BUILD: build-image
;;;   From COMMAND: start-command-processor, user-context,
;;;                 package-for-commands

(define %internal-full-command-line '())
(define %internal-command-line-arguments '())
(define (command-line) (append %internal-command-line-arguments '()))

(define scsh-major-version 0)
(define scsh-minor-version 5)
(define scsh-version-string "0.5.0")

;;; A scsh starter takes the command line args, parses them, 
;;; initialises the scsh system, and either starts up a repl loop
;;; or executes the -s script.
(define (make-scsh-starter)
  (let ((env (environment-for-commands))
	(context (user-context)))
    (lambda (args)
      (receive (script args) (parse-scsh-args args)
	(set! command-line-arguments (append args '()))
	(cond (script		;Batch
	       (set! %internal-command-line-arguments
		     (cons script args))
	       (load-quietly1 script env)
	       0)			; exit code

	      (else		; Interactive
	       (with-interaction-environment env
	         (lambda ()
		   (set-batch-mode?! #t)
		   (set! %internal-command-line-arguments
			 (cons "scsh" args))
		   (start-command-processor ""
					    context
					    (lambda ()
					      (display "Scsh ")
					      (display scsh-version-string)
					      (newline)
					      ))))))))))

;;; Make a different kind of starter. This one initialises the
;;; scsh run time, then simply calls the user's program.
;;;
;;; It should take an arg to determine what kind of a condition
;;; system you'd like in place. 

(define (make-top-level main)
  (lambda (args)
    (set! %internal-full-command-line args)
    (set! %internal-command-line-arguments (cons "" args))
    (init-scsh #f #t)
    (set! command-line-arguments (append args '()))
    (main)
    0))

(define (repl)
  (command-loop (lambda () (set-batch-mode?! #f))
		#f))


(define (bad-args arg-list)
  (error "Bad argument list to scsh.
Useage: scsh [<end-option> <arg1> ... <argn>]
<end-option>: -s <script-file>
              --  (Terminates option parsing)" arg-list))

(define (parse-scsh-args arg-list)
  (if (pair? arg-list)
      (let ((arg1 (car arg-list))
	    (rest (cdr arg-list)))
	(cond ((string=? arg1 "-s")
	       (if (pair? rest)
		   (values (car rest) (cdr rest))
		   (bad-args arg-list)))
	      ((string=? arg1 "--") (values #f rest))
	      (else (bad-args arg-list))))
      (values #f '())))
      

;;; BUILD-IMAGE calls the starter after installing a fatal top-level
;;; error handler. MAKE-SCSH-STARTER shadows it in the interactive case.

(define (dump-scsh fname)
  (build-scsh-image (make-scsh-starter) fname))

(define (dump-scsh-program main fname)
  (build-scsh-image main fname))

;;; Hacked because s48's compiler's scanner insists on echoing the file name.

(define (load-quietly1 fname package)
  (call-with-input-file fname
    (lambda (port)
      (let loop ()
	(let ((form (read port)))
	  (if (not (eof-object? form))
	      (begin (eval form package)
		     (loop))))))))

;;; Had to define these as the ones in s48's build.scm do not properly
;;; initialise ERROR-OUTPUT-PORT to stderr -- this is a bug in the vm's
;;; handoff to the very first Scheme form (it passes two ports -- not three).
;;; Until Kelsey fixes these, we hack it with these replacements, which
;;; invoke INIT-SCSH, which re-initialises the I/O system to be what
;;; you wanted.

(define (build-scsh-image start filename)
  (let ((filename (translate filename)))
    (display (string-append "Writing " filename) (command-output))
    (newline (command-output))
    (flush-the-symbol-table!)	;Gets restored at next use of string->symbol
    (write-image filename
		 (scsh-stand-alone-resumer start)
		 "")
    #t))

(define (scsh-stand-alone-resumer start)
  (usual-resumer  ;sets up exceptions, interrupts, and current input & output
   (lambda (args)
     (init-scsh #f #f)	; Whatever. Install scsh's I/O system.
     (call-with-current-continuation
       (lambda (halt)
	 (set! command-line-arguments (append args '()))
	 (set! %internal-full-command-line args)
	 (set! %internal-command-line-arguments (cons "" args))	; WRONG
	 (with-handler (simple-condition-handler halt (error-output-port))
	   (lambda ()
	     (start args))))))))