From 26447c1d1aa5084930c89bd55fd702579e859792 Mon Sep 17 00:00:00 2001 From: marting Date: Fri, 24 Sep 1999 23:52:32 +0000 Subject: [PATCH] added channel-cell-ref to newports for the changed design in rts/channel-port.s, vm starts from dumped image now --- scsh/newports.scm | 9 +++++---- scsh/scsh.scm | 33 ++++++++++++++++++--------------- scsh/startup.scm | 5 ++++- scsh/top.scm | 14 +++++++------- 4 files changed, 34 insertions(+), 27 deletions(-) diff --git a/scsh/newports.scm b/scsh/newports.scm index da610f3..a74ae0c 100644 --- a/scsh/newports.scm +++ b/scsh/newports.scm @@ -29,7 +29,7 @@ (define (install-fdport fdport) (let* ((fdport* (fdport-data fdport)) (ch (fdport-data:channel fdport*)) - (ch-number (channel-os-index ch))) + (ch-number (channel-os-index ch))) (if (fdport-data:revealed fdport*) (vector-set! fdports ch-number fdport) (weak-vector-set! fdports ch-number fdport)))) @@ -43,7 +43,7 @@ ;Hmm... these shouldn't be necessary. But still. ;Fake defrec routines for backwards compatibility. (define (fdport-data:fd fdport*) - (channel-os-index (fdport-data:channel fdport*))) + (channel-os-index (channel-cell-ref (fdport-data:channel fdport*)))) (define (fdport-data:closed? fdport*) (eq? (channel-status (fdport-data:channel fdport*)) @@ -63,7 +63,7 @@ ;The two following routines are to build ports from stdin and stdout channels. (define (channel-port->input-fdport channel-port) (let ((p (make-input-port input-fdport-handler - (make-fdport-data (port-data channel-port) 1) + (make-fdport-data (channel-cell-ref (port-data channel-port)) 1) (make-code-vector buffer-size 0) 0 0))) (obtain-port-lock channel-port) (set-port-lock! p (port-lock channel-port)) @@ -74,7 +74,7 @@ (define (channel-port->output-fdport channel-port) (let ((p (make-output-port output-fdport-handler - (make-fdport-data (port-data channel-port) 1) + (make-fdport-data (channel-cell-ref(port-data channel-port)) 1) (make-code-vector buffer-size 0) 0 buffer-size))) (obtain-port-lock channel-port) (set-port-lock! p (port-lock channel-port)) @@ -278,6 +278,7 @@ (set! old-errport (current-error-port))) (set-fluid! $current-input-port (channel-port->input-fdport (current-input-port))) (set-fluid! $current-output-port (channel-port->output-fdport (current-output-port))) + (set-fluid! $current-error-port (channel-port->output-fdport (current-error-port)))) diff --git a/scsh/scsh.scm b/scsh/scsh.scm index e8ae271..b471b90 100644 --- a/scsh/scsh.scm +++ b/scsh/scsh.scm @@ -127,7 +127,7 @@ ;; Main loop. (let split ((i 0)) - (cond ((index clist #\: i) => + (cond ((string-index clist #\: i) => (lambda (colon) (cons (substring clist i colon) (split (+ colon 1))))) @@ -209,10 +209,10 @@ (define (with-env* alist-delta thunk) (let* ((old-env #f) - (new-env (reduce (lambda (alist key/val) - (alist-update (car key/val) (cdr key/val) alist)) - (env->alist) - alist-delta))) + (new-env (fold (lambda (key/val alist) + (alist-update (car key/val) (cdr key/val) alist)) + (env->alist) + alist-delta))) (dynamic-wind (lambda () (set! old-env (env->alist)) @@ -437,12 +437,12 @@ ;;; (port->list reader port) ;;; Repeatedly applies READER to PORT, accumulating results into a list. ;;; On EOF, returns the list of items thus collected. -;;; (reduce-port port reader op . seeds) +;;; (port-fold port reader op . seeds) ;;; Repeatedly read things from PORT with READER. Each time you read ;;; some value V, compute a new set of seeds with (apply OP V SEEDS). ;;; (More than 1 seed means OP must return multiple values). -;;; On eof, return the seeds. -;;; PORT->LIST is just (REDUCE-PORT PORT READ CONS '()) +;;; On eof, return the seeds: (apply value SEEDS). +;;; PORT->LIST is just (PORT-FOLD PORT READ CONS '()) (define (run/port+proc* thunk) (receive (r w) (pipe) @@ -507,13 +507,16 @@ (define (port->string-list port) (port->list read-line port)) -(define (reduce-port port reader op . seeds) - (letrec ((reduce (lambda seeds +(define (port-fold port reader op . seeds) + (letrec ((fold (lambda seeds (let ((x (reader port))) (if (eof-object? x) (apply values seeds) (call-with-values (lambda () (apply op x seeds)) - reduce)))))) - (apply reduce seeds))) + fold)))))) + (apply fold seeds))) + +(define reduce-port + (deprecated-proc port-fold 'reduce-port "Use port-fold instead.")) ;;; Not defined: ;;; (field-reader field-delims record-delims) @@ -624,7 +627,7 @@ (arg* arglist n))) (define (argv n . maybe-default) - (apply arg (cdr %command-line) n maybe-default)) + (apply arg %command-line (+ n 1) maybe-default)) (define (command-line) (append %command-line '())) @@ -673,7 +676,7 @@ (define (exec-path/env prog env . arglist) (flush-all-ports) (let ((prog (stringify prog))) - (if (index prog #\/) + (if (string-index prog #\/) ;; Contains a slash -- no path search. (%exec prog (cons prog arglist) env) @@ -736,7 +739,7 @@ ;;; Low-level init absolutely required for any scsh program. (define (init-scsh-hindbrain relink-ff?) - (if relink-ff? (lookup-all-externals)) ; Re-link C calls. +; (if relink-ff? (lookup-all-externals)) ; Re-link C calls. (init-fdports!) (%install-unix-scsh-handlers)) diff --git a/scsh/startup.scm b/scsh/startup.scm index 540c10d..6162fc5 100644 --- a/scsh/startup.scm +++ b/scsh/startup.scm @@ -63,7 +63,10 @@ (define (scsh-stand-alone-resumer start) (usual-resumer ;sets up exceptions, interrupts, and current input & output (lambda (args) ; VM gives us our args, but not our program. - ;JMG (init-scsh-hindbrain #t) ; Whatever. Relink & install scsh's I/O system. + (display "start0" (current-error-port)) + (init-fdports!) + (display "start00" (current-error-port)) + ;JMG (init-scsh-hindbrain #t) ; Whatever. Relink & install scsh's I/O system. (call-with-current-continuation (lambda (halt) (display "start" (current-error-port)) diff --git a/scsh/top.scm b/scsh/top.scm index 2b7787b..45e78f3 100644 --- a/scsh/top.scm +++ b/scsh/top.scm @@ -269,18 +269,17 @@ (cond ((not term-switch) ; -- interactive (display "scsh is up" (current-error-port)) - + (init-scsh-vars #t) + (display "fdports installed" (current-error-port)) ; (interrupt-before-heap-overflow!) (let ((repl-data #f) ;no condition - (repl-thunk real-command-loop) - (start-thunk (lambda () - (display "i am start thunk")))) + (repl-thunk real-command-loop)) (let ((thunk (really-push-command-level repl-thunk repl-data (get-dynamic-env) '()))) (ignore-further-interrupts) - (thunk)))) + thunk))) ; (command-loop ;(lambda () @@ -294,7 +293,8 @@ ((eq? term-switch 'c) - (eval (read-exactly-one-sexp-from-string term-val) + ;;; JMG eval now needs expr represented as data + (eval '(read-exactly-one-sexp-from-string term-val) (interaction-environment)) (exit 0)) @@ -317,7 +317,7 @@ (define (bad-arg . msg) - (with-current-output-port (error-output-port) + (with-current-output-port (current-error-port) (for-each (lambda (x) (display x) (write-char #\space)) msg) (newline) (display "Useage: scsh [meta-arg] [switch ..] [end-option arg ...]