diff --git a/scsh/oldtop.scm b/scsh/oldtop.scm deleted file mode 100644 index 61b8a04..0000000 --- a/scsh/oldtop.scm +++ /dev/null @@ -1,133 +0,0 @@ -;;; 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.1") - -;;; 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 [ ... ] -: -s - -- (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 (current-error-port)) - (lambda () - (start args))))))))