scsh-0.5/scsh/oldtop.scm

134 lines
4.2 KiB
Scheme

;;; 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 4)
(define scsh-version-string "0.4.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))))))))