134 lines
4.2 KiB
Scheme
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))))))))
|