added channel-cell-ref to newports for the changed design in rts/channel-port.s, vm starts from dumped image now

This commit is contained in:
marting 1999-09-24 23:52:32 +00:00
parent b5771115b6
commit 26447c1d1a
4 changed files with 34 additions and 27 deletions

View File

@ -29,7 +29,7 @@
(define (install-fdport fdport) (define (install-fdport fdport)
(let* ((fdport* (fdport-data fdport)) (let* ((fdport* (fdport-data fdport))
(ch (fdport-data:channel fdport*)) (ch (fdport-data:channel fdport*))
(ch-number (channel-os-index ch))) (ch-number (channel-os-index ch)))
(if (fdport-data:revealed fdport*) (if (fdport-data:revealed fdport*)
(vector-set! fdports ch-number fdport) (vector-set! fdports ch-number fdport)
(weak-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. ;Hmm... these shouldn't be necessary. But still.
;Fake defrec routines for backwards compatibility. ;Fake defrec routines for backwards compatibility.
(define (fdport-data:fd fdport*) (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*) (define (fdport-data:closed? fdport*)
(eq? (channel-status (fdport-data:channel 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. ;The two following routines are to build ports from stdin and stdout channels.
(define (channel-port->input-fdport channel-port) (define (channel-port->input-fdport channel-port)
(let ((p (make-input-port input-fdport-handler (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))) (make-code-vector buffer-size 0) 0 0)))
(obtain-port-lock channel-port) (obtain-port-lock channel-port)
(set-port-lock! p (port-lock channel-port)) (set-port-lock! p (port-lock channel-port))
@ -74,7 +74,7 @@
(define (channel-port->output-fdport channel-port) (define (channel-port->output-fdport channel-port)
(let ((p (make-output-port output-fdport-handler (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))) (make-code-vector buffer-size 0) 0 buffer-size)))
(obtain-port-lock channel-port) (obtain-port-lock channel-port)
(set-port-lock! p (port-lock channel-port)) (set-port-lock! p (port-lock channel-port))
@ -278,6 +278,7 @@
(set! old-errport (current-error-port))) (set! old-errport (current-error-port)))
(set-fluid! $current-input-port (channel-port->input-fdport (current-input-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-output-port (channel-port->output-fdport (current-output-port)))
(set-fluid! $current-error-port (channel-port->output-fdport (current-error-port)))) (set-fluid! $current-error-port (channel-port->output-fdport (current-error-port))))

View File

@ -127,7 +127,7 @@
;; Main loop. ;; Main loop.
(let split ((i 0)) (let split ((i 0))
(cond ((index clist #\: i) => (cond ((string-index clist #\: i) =>
(lambda (colon) (lambda (colon)
(cons (substring clist i colon) (cons (substring clist i colon)
(split (+ colon 1))))) (split (+ colon 1)))))
@ -209,10 +209,10 @@
(define (with-env* alist-delta thunk) (define (with-env* alist-delta thunk)
(let* ((old-env #f) (let* ((old-env #f)
(new-env (reduce (lambda (alist key/val) (new-env (fold (lambda (key/val alist)
(alist-update (car key/val) (cdr key/val) alist)) (alist-update (car key/val) (cdr key/val) alist))
(env->alist) (env->alist)
alist-delta))) alist-delta)))
(dynamic-wind (dynamic-wind
(lambda () (lambda ()
(set! old-env (env->alist)) (set! old-env (env->alist))
@ -437,12 +437,12 @@
;;; (port->list reader port) ;;; (port->list reader port)
;;; Repeatedly applies READER to PORT, accumulating results into a list. ;;; Repeatedly applies READER to PORT, accumulating results into a list.
;;; On EOF, returns the list of items thus collected. ;;; 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 ;;; 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). ;;; some value V, compute a new set of seeds with (apply OP V SEEDS).
;;; (More than 1 seed means OP must return multiple values). ;;; (More than 1 seed means OP must return multiple values).
;;; On eof, return the seeds. ;;; On eof, return the seeds: (apply value SEEDS).
;;; PORT->LIST is just (REDUCE-PORT PORT READ CONS '()) ;;; PORT->LIST is just (PORT-FOLD PORT READ CONS '())
(define (run/port+proc* thunk) (define (run/port+proc* thunk)
(receive (r w) (pipe) (receive (r w) (pipe)
@ -507,13 +507,16 @@
(define (port->string-list port) (define (port->string-list port)
(port->list read-line port)) (port->list read-line port))
(define (reduce-port port reader op . seeds) (define (port-fold port reader op . seeds)
(letrec ((reduce (lambda seeds (letrec ((fold (lambda seeds
(let ((x (reader port))) (let ((x (reader port)))
(if (eof-object? x) (apply values seeds) (if (eof-object? x) (apply values seeds)
(call-with-values (lambda () (apply op x seeds)) (call-with-values (lambda () (apply op x seeds))
reduce)))))) fold))))))
(apply reduce seeds))) (apply fold seeds)))
(define reduce-port
(deprecated-proc port-fold 'reduce-port "Use port-fold instead."))
;;; Not defined: ;;; Not defined:
;;; (field-reader field-delims record-delims) ;;; (field-reader field-delims record-delims)
@ -624,7 +627,7 @@
(arg* arglist n))) (arg* arglist n)))
(define (argv n . maybe-default) (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 '())) (define (command-line) (append %command-line '()))
@ -673,7 +676,7 @@
(define (exec-path/env prog env . arglist) (define (exec-path/env prog env . arglist)
(flush-all-ports) (flush-all-ports)
(let ((prog (stringify prog))) (let ((prog (stringify prog)))
(if (index prog #\/) (if (string-index prog #\/)
;; Contains a slash -- no path search. ;; Contains a slash -- no path search.
(%exec prog (cons prog arglist) env) (%exec prog (cons prog arglist) env)
@ -736,7 +739,7 @@
;;; Low-level init absolutely required for any scsh program. ;;; Low-level init absolutely required for any scsh program.
(define (init-scsh-hindbrain relink-ff?) (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!) (init-fdports!)
(%install-unix-scsh-handlers)) (%install-unix-scsh-handlers))

View File

@ -63,7 +63,10 @@
(define (scsh-stand-alone-resumer start) (define (scsh-stand-alone-resumer start)
(usual-resumer ;sets up exceptions, interrupts, and current input & output (usual-resumer ;sets up exceptions, interrupts, and current input & output
(lambda (args) ; VM gives us our args, but not our program. (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 (call-with-current-continuation
(lambda (halt) (lambda (halt)
(display "start" (current-error-port)) (display "start" (current-error-port))

View File

@ -269,18 +269,17 @@
(cond ((not term-switch) ; -- interactive (cond ((not term-switch) ; -- interactive
(display "scsh is up" (current-error-port)) (display "scsh is up" (current-error-port))
(init-scsh-vars #t)
(display "fdports installed" (current-error-port))
; (interrupt-before-heap-overflow!) ; (interrupt-before-heap-overflow!)
(let ((repl-data #f) ;no condition (let ((repl-data #f) ;no condition
(repl-thunk real-command-loop) (repl-thunk real-command-loop))
(start-thunk (lambda ()
(display "i am start thunk"))))
(let ((thunk (really-push-command-level repl-thunk (let ((thunk (really-push-command-level repl-thunk
repl-data repl-data
(get-dynamic-env) (get-dynamic-env)
'()))) '())))
(ignore-further-interrupts) (ignore-further-interrupts)
(thunk)))) thunk)))
; ;
(command-loop (command-loop
;(lambda () ;(lambda ()
@ -294,7 +293,8 @@
((eq? term-switch 'c) ((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)) (interaction-environment))
(exit 0)) (exit 0))
@ -317,7 +317,7 @@
(define (bad-arg . msg) (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) (for-each (lambda (x) (display x) (write-char #\space)) msg)
(newline) (newline)
(display "Useage: scsh [meta-arg] [switch ..] [end-option arg ...] (display "Useage: scsh [meta-arg] [switch ..] [end-option arg ...]