Hacked file-loading code so that we could load from ports. This to support
the new -s- switch.
This commit is contained in:
parent
0d7befeb82
commit
d8d1758d11
|
@ -38,6 +38,10 @@
|
||||||
p filename run
|
p filename run
|
||||||
noisy?))
|
noisy?))
|
||||||
|
|
||||||
|
(define (compile-and-run-port port p run noisy?)
|
||||||
|
(compile-and-run-scanned-forms (really-scan-port port p)
|
||||||
|
p #f run noisy?))
|
||||||
|
|
||||||
; --------------------
|
; --------------------
|
||||||
|
|
||||||
; If non-noisy, this tail-recurs to last form.
|
; If non-noisy, this tail-recurs to last form.
|
||||||
|
|
|
@ -40,29 +40,40 @@
|
||||||
(define (scan-file pathname p . env-option)
|
(define (scan-file pathname p . env-option)
|
||||||
(apply really-scan-file pathname p (current-output-port) env-option))
|
(apply really-scan-file pathname p (current-output-port) env-option))
|
||||||
|
|
||||||
(define (really-scan-file pathname p noise . env-option)
|
(define (really-scan-port port p . env-option) ; For scsh
|
||||||
(let* ((env (if (null? env-option)
|
(let* ((env (if (null? env-option)
|
||||||
(package->environment p)
|
(package->environment p)
|
||||||
(car env-option)))
|
(car env-option)))
|
||||||
(filename (namestring pathname #f *scheme-file-type*))
|
(reader (environment-reader env)))
|
||||||
(truename (translate filename)))
|
(let recur ()
|
||||||
|
(let ((form (reader port)))
|
||||||
|
(if (eof-object? form)
|
||||||
|
'()
|
||||||
|
(append (scan-form form p env)
|
||||||
|
(recur)))))))
|
||||||
|
|
||||||
|
(define (really-scan-file pathname p noise . env-option)
|
||||||
|
(let* ((env (if (null? env-option)
|
||||||
|
(package->environment p)
|
||||||
|
(car env-option)))
|
||||||
|
(filename (namestring pathname #f *scheme-file-type*))
|
||||||
|
(truename (translate filename)))
|
||||||
(call-with-input-file truename
|
(call-with-input-file truename
|
||||||
(lambda (port)
|
(lambda (port)
|
||||||
(if filename ((fluid $note-file-package) filename p))
|
(if filename ((fluid $note-file-package) filename p))
|
||||||
(let ((env (bind-source-file-name filename env))
|
(let ((env (bind-source-file-name filename env))
|
||||||
(reader (environment-reader env)))
|
(reader (environment-reader env)))
|
||||||
(cond (noise (display truename noise)
|
(cond (noise (display truename noise)
|
||||||
(force-output noise)))
|
(force-output noise)))
|
||||||
(let ((result (let recur ()
|
(let ((result (let recur ()
|
||||||
(let ((form (read port)))
|
(let ((form (read port)))
|
||||||
(if (eof-object? form)
|
(if (eof-object? form)
|
||||||
'()
|
'()
|
||||||
(append (scan-form form p env)
|
(append (scan-form form p env)
|
||||||
(recur)))))))
|
(recur)))))))
|
||||||
(cond (noise (display #\space noise)
|
(cond (noise (display #\space noise)
|
||||||
(force-output noise)))
|
(force-output noise)))
|
||||||
result))))))
|
result))))))
|
||||||
|
|
||||||
|
|
||||||
; --------------------
|
; --------------------
|
||||||
; Process a list of forms.
|
; Process a list of forms.
|
||||||
|
|
|
@ -85,7 +85,20 @@
|
||||||
(eval form env)
|
(eval form env)
|
||||||
(loop))))))))
|
(loop))))))))
|
||||||
|
|
||||||
(define load-quietly load-into) ; For scsh.
|
;;; For scsh.
|
||||||
|
;;; Identical to LOAD-INTO, but accepts either a filename or port.
|
||||||
|
|
||||||
|
(define (load-quietly from env)
|
||||||
|
(let ((doit (lambda (port)
|
||||||
|
(let loop ()
|
||||||
|
(let ((form (read port)))
|
||||||
|
(cond ((eof-object? form))
|
||||||
|
(else
|
||||||
|
(eval form env)
|
||||||
|
(loop))))))))
|
||||||
|
(if (input-port? from) (doit from)
|
||||||
|
(call-with-input-file from doit))))
|
||||||
|
|
||||||
|
|
||||||
(define (eval-from-file forms env filename)
|
(define (eval-from-file forms env filename)
|
||||||
(for-each (lambda (form) (eval form env)) forms))
|
(for-each (lambda (form) (eval form env)) forms))
|
||||||
|
|
|
@ -245,11 +245,15 @@
|
||||||
(package->environment package)
|
(package->environment package)
|
||||||
filename))
|
filename))
|
||||||
|
|
||||||
(define (load-quietly filename package)
|
(define (load-quietly from package) ; No noise. For scsh.
|
||||||
(eval-nodes (really-scan-file filename package #f) ; No noise. For scsh.
|
(display from)
|
||||||
(package->environment package)
|
(if (string? from)
|
||||||
filename))
|
(eval-nodes (really-scan-file from package #f)
|
||||||
|
(package->environment package)
|
||||||
|
from)
|
||||||
|
(eval-nodes (really-scan-port from package)
|
||||||
|
(package->environment package)
|
||||||
|
#f)))
|
||||||
|
|
||||||
(define (eval-from-file forms p file) ;Scheme 48 internal thing
|
(define (eval-from-file forms p file) ;Scheme 48 internal thing
|
||||||
(eval-forms forms p file))
|
(eval-forms forms p file))
|
||||||
|
|
1477
initial.debug
1477
initial.debug
File diff suppressed because it is too large
Load Diff
BIN
initial.image
BIN
initial.image
Binary file not shown.
|
@ -732,6 +732,7 @@
|
||||||
(export scan-forms
|
(export scan-forms
|
||||||
scan-file
|
scan-file
|
||||||
really-scan-file
|
really-scan-file
|
||||||
|
really-scan-port ; for scsh
|
||||||
scan-structures ;load-package.scm, link/link.scm
|
scan-structures ;load-package.scm, link/link.scm
|
||||||
really-scan-structures
|
really-scan-structures
|
||||||
scan-package
|
scan-package
|
||||||
|
@ -762,6 +763,7 @@
|
||||||
(define-interface compiler-interface
|
(define-interface compiler-interface
|
||||||
(export compile
|
(export compile
|
||||||
compile-and-run-file ;for LOAD
|
compile-and-run-file ;for LOAD
|
||||||
|
compile-and-run-port ;for LOAD (in scsh)
|
||||||
compile-and-run-forms ;for EVAL
|
compile-and-run-forms ;for EVAL
|
||||||
compile-and-run-scanned-forms ;for eval.scm / ensure-loaded
|
compile-and-run-scanned-forms ;for eval.scm / ensure-loaded
|
||||||
compile-file ;link/link.scm
|
compile-file ;link/link.scm
|
||||||
|
|
11
rts/eval.scm
11
rts/eval.scm
|
@ -25,11 +25,12 @@
|
||||||
|
|
||||||
; For scsh.
|
; For scsh.
|
||||||
|
|
||||||
(define (load-quietly filename p)
|
(define (load-quietly from p)
|
||||||
(compile-and-run-file filename p
|
((if (string? from) compile-and-run-file compile-and-run-port)
|
||||||
(lambda (template)
|
from p
|
||||||
(invoke-template template p))
|
(lambda (template)
|
||||||
#f))
|
(invoke-template template p))
|
||||||
|
#f))
|
||||||
|
|
||||||
; Evaluate forms as if they came from the given file.
|
; Evaluate forms as if they came from the given file.
|
||||||
|
|
||||||
|
|
18
scsh/top.scm
18
scsh/top.scm
|
@ -45,6 +45,7 @@
|
||||||
;;; Terminating switches:
|
;;; Terminating switches:
|
||||||
;;; -c <exp> Eval <exp>, then exit.
|
;;; -c <exp> Eval <exp>, then exit.
|
||||||
;;; -s <script> Specify <script> to be loaded by a -ds or -dm.
|
;;; -s <script> Specify <script> to be loaded by a -ds or -dm.
|
||||||
|
;;; -s- Script is standard input.
|
||||||
;;; -- Interactive scsh.
|
;;; -- Interactive scsh.
|
||||||
|
|
||||||
|
|
||||||
|
@ -53,8 +54,10 @@
|
||||||
;;; - We first expand out any initial \ <filename> meta-arg.
|
;;; - We first expand out any initial \ <filename> meta-arg.
|
||||||
;;; - A switch-list elt is either "-ds", "-dm", or a (switch . arg) pair
|
;;; - A switch-list elt is either "-ds", "-dm", or a (switch . arg) pair
|
||||||
;;; for a -o, -n, -m, -l, or -lm switch.
|
;;; for a -o, -n, -m, -l, or -lm switch.
|
||||||
;;; - Terminating switch is one of {s, c, #f} for -s, -c, and -- respectively.
|
;;; - Terminating switch is one of {s, c, #f} for -s or -s-, -c,
|
||||||
;;; - Terminating arg is the <exp> arg to -c, the <script> arg to -s, otw #f.
|
;;; and -- respectively.
|
||||||
|
;;; - Terminating arg is the <exp> arg to -c, the <script> arg to -s,
|
||||||
|
;;; the standard input port for -s-, otw #f.
|
||||||
;;; - top-entry is the <entry> arg to a -e; #f if none.
|
;;; - 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
|
;;; - command-line args are what's left over after picking off the scsh
|
||||||
;;; switches.
|
;;; switches.
|
||||||
|
@ -80,6 +83,10 @@
|
||||||
(values (reverse switches) 's (car args)
|
(values (reverse switches) 's (car args)
|
||||||
top-entry (cdr args))))
|
top-entry (cdr args))))
|
||||||
|
|
||||||
|
((string=? arg "-s-")
|
||||||
|
(values (reverse switches) 's (current-input-port)
|
||||||
|
top-entry args))
|
||||||
|
|
||||||
((string=? arg "--")
|
((string=? arg "--")
|
||||||
(if need-script?
|
(if need-script?
|
||||||
(bad-arg "-ds or -dm switch requires -s <script>")
|
(bad-arg "-ds or -dm switch requires -s <script>")
|
||||||
|
@ -280,9 +287,10 @@ switch: -e <entry-point> Specify top-level entry point.
|
||||||
-ds Do script.
|
-ds Do script.
|
||||||
-dm Do script module.
|
-dm Do script module.
|
||||||
|
|
||||||
end-option: -s <script>
|
end-option: -s <script> Specify script.
|
||||||
-c <exp>
|
-s- Script is standard input.
|
||||||
--
|
-c <exp> Evaluate expression.
|
||||||
|
-- Interactive session.
|
||||||
"))
|
"))
|
||||||
(exit -1))
|
(exit -1))
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue