#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.6 1989/08/07 07:36:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.7 1990/06/20 20:28:51 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (letter-commands command-set message prompt state)
(with-standard-proceed-point
(lambda ()
- (push-cmdl letter-commands/driver
- (vector command-set prompt state)
- message))))
+ (let ((state (vector command-set prompt state))
+ (cmdl (nearest-cmdl)))
+ (let ((input-port (cmdl/input-port cmdl)))
+ (input-port/immediate-mode input-port
+ (lambda ()
+ (make-cmdl cmdl
+ input-port
+ (cmdl/output-port cmdl)
+ letter-commands/driver
+ state
+ message))))))))
(define (letter-commands/driver cmdl)
(let ((command-set (vector-ref (cmdl/state cmdl) 0))
(hook/leaving-command-loop thunk))
(define (default/leaving-command-loop thunk)
- (thunk))
+ (input-port/normal-mode (cmdl/input-port (nearest-cmdl)) thunk))
(define (debug/read-eval-print environment message prompt)
(leaving-command-loop
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.3 1989/08/07 07:36:34 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.4 1990/06/20 20:28:56 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(declare (usual-integrations))
\f
-(define-primitives
- tty-read-char-ready?
- tty-read-char-immediate
- (under-emacs? 0))
-
(define (transmit-signal type)
(write-char #\Altmode console-output-port)
(write-char type console-output-port))
(transmit-signal #\g)
(normal/^G-interrupt interrupt-enables))
-(define (emacs/read-char-immediate)
- (emacs/read-start)
- (let ((char (tty-read-char-immediate)))
- (emacs/read-finish)
- char))
-
(define (emacs/read-command-char cmdl prompt)
(if (cmdl/io-to-console? cmdl)
(begin
(normal/prompt-for-expression cmdl prompt)))
(define (read-char-internal)
- (let ((char (emacs/read-char-immediate)))
- (if (char=? char char:newline)
- (read-char-internal)
- char)))
+ (emacs/read-start)
+ (let loop ()
+ (let ((char (input-port/read-char console-input-port)))
+ (if (char=? char char:newline)
+ (loop)
+ (begin
+ (emacs/read-finish)
+ char)))))
(define (cmdl/io-to-console? cmdl)
(and (eq? console-input-port (cmdl/input-port cmdl))
(define normal/cmdl-prompt)
(define normal/repl-write)
(define normal/repl-read)
-(define normal/read-char-immediate)
(define normal/read-start)
(define normal/read-finish)
(define normal/error-decision)
(set! normal/cmdl-prompt hook/cmdl-prompt)
(set! normal/repl-write hook/repl-write)
(set! normal/repl-read hook/repl-read)
- (set! normal/read-char-immediate hook/read-char-immediate)
(set! normal/read-start hook/read-start)
(set! normal/read-finish hook/read-finish)
(set! normal/error-decision hook/error-decision)
(install!))
\f
(define (install!)
- ((if (under-emacs?)
+ ((if ((ucode-primitive under-emacs? 0))
install-emacs-hooks!
install-normal-hooks!)))
(set! hook/cmdl-prompt emacs/cmdl-prompt)
(set! hook/repl-write emacs/repl-write)
(set! hook/repl-read emacs/repl-read)
- (set! hook/read-char-immediate emacs/read-char-immediate)
(set! hook/read-start emacs/read-start)
(set! hook/read-finish emacs/read-finish)
(set! hook/error-decision emacs/error-decision)
(set! hook/cmdl-prompt normal/cmdl-prompt)
(set! hook/repl-write normal/repl-write)
(set! hook/repl-read normal/repl-read)
- (set! hook/read-char-immediate normal/read-char-immediate)
(set! hook/read-start normal/read-start)
(set! hook/read-finish normal/read-finish)
(set! hook/error-decision normal/error-decision)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 14.5 1989/10/26 06:46:27 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 14.6 1990/06/20 20:29:14 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(operation/char-ready? false read-only true)
(operation/peek-char false read-only true)
(operation/read-char false read-only true)
- (operation/peek-char-immediate false read-only true)
- (operation/read-char-immediate false read-only true)
(operation/discard-char false read-only true)
(operation/read-string false read-only true)
(operation/discard-chars false read-only true)
- (operation/read-start! false read-only true)
- (operation/read-finish! false read-only true)
- (custom-operations false read-only true))
+ (custom-operations false read-only true)
+ (operation-names false read-only true))
(define (guarantee-input-port port)
(if (not (input-port? port)) (error "Bad input port" port))
(cdr entry))))
(define (input-port/operation port name)
+ ;; Try the custom operations first since the user is less likely to
+ ;; use this procedure to access the standard operations.
(or (input-port/custom-operation port name)
(case name
- ((OPERATION/CHAR-READY?) (input-port/operation/char-ready? port))
- ((OPERATION/PEEK-CHAR) (input-port/operation/peek-char port))
- ((OPERATION/READ-CHAR) (input-port/operation/read-char port))
- ((OPERATION/PEEK-CHAR-IMMEDIATE)
- (input-port/operation/peek-char-immediate port))
- ((OPERATION/READ-CHAR-IMMEDIATE)
- (input-port/operation/read-char-immediate port))
- ((OPERATION/DISCARD-CHAR) (input-port/operation/discard-char port))
- ((OPERATION/READ-STRING) (input-port/operation/read-string port))
- ((OPERATION/DISCARD-CHARS) (input-port/operation/discard-chars port))
- ((OPERATION/READ-START!) (input-port/operation/read-start! port))
- ((OPERATION/READ-FINISH!) (input-port/operation/read-finish! port))
+ ((CHAR-READY?) (input-port/operation/char-ready? port))
+ ((PEEK-CHAR) (input-port/operation/peek-char port))
+ ((READ-CHAR) (input-port/operation/read-char port))
+ ((DISCARD-CHAR) (input-port/operation/discard-char port))
+ ((READ-STRING) (input-port/operation/read-string port))
+ ((DISCARD-CHARS) (input-port/operation/discard-chars port))
(else false))))
\f
(define (make-input-port operations state)
(lambda (name default)
(let ((entry (assq name operations)))
(if entry
- (begin (set! operations (delq! entry operations))
- (cdr entry))
+ (begin
+ (set! operations (delq! entry operations))
+ (cdr entry))
(or default
(error "MAKE-INPUT-PORT: missing operation" name)))))))
(let ((char-ready? (operation 'CHAR-READY? false))
(peek-char (operation 'PEEK-CHAR false))
- (read-char (operation 'READ-CHAR false))
- (read-string
- (operation 'READ-STRING default-operation/read-string))
- (discard-chars
- (operation 'DISCARD-CHARS default-operation/discard-chars))
- (read-start!
- (operation 'READ-START! default-operation/read-start!))
- (read-finish!
- (operation 'READ-FINISH! default-operation/read-finish!)))
- (let ((peek-char-immediate (operation 'PEEK-CHAR-IMMEDIATE peek-char))
- (read-char-immediate (operation 'READ-CHAR-IMMEDIATE read-char))
- (discard-char (operation 'DISCARD-CHAR read-char)))
+ (read-char (operation 'READ-CHAR false)))
+ (let ((discard-char (operation 'DISCARD-CHAR read-char))
+ (read-string
+ (operation 'READ-STRING default-operation/read-string))
+ (discard-chars
+ (operation 'DISCARD-CHARS default-operation/discard-chars)))
(%make-input-port state
char-ready?
peek-char
read-char
- peek-char-immediate
- read-char-immediate
discard-char
read-string
discard-chars
- read-start!
- read-finish!
- operations))))))
+ operations
+ (append '(CHAR-READY?
+ PEEK-CHAR
+ READ-CHAR
+ DISCARD-CHAR
+ READ-STRING
+ DISCARD-CHARS)
+ (map car operations))))))))
(define (default-operation/read-string port delimiters)
(list->string
(if (not (char-set-member? delimiters (peek-char port)))
(begin (discard-char port)
(loop))))))
-
-(define (default-operation/read-start! port)
- port
- false)
-
-(define (default-operation/read-finish! port)
- port
- false)
\f
(define (input-port/char-ready? port interval)
((input-port/operation/char-ready? port) port interval))
(define (input-port/read-char port)
((input-port/operation/read-char port) port))
-(define (input-port/peek-char-immediate port)
- ((input-port/operation/peek-char-immediate port) port))
-
-(define (input-port/read-char-immediate port)
- ((input-port/operation/read-char-immediate port) port))
-
(define (input-port/discard-char port)
((input-port/operation/discard-char port) port))
(define (input-port/discard-chars port delimiters)
((input-port/operation/discard-chars port) port delimiters))
-(define (input-port/read-start! port)
- ((input-port/operation/read-start! port) port))
+(define (input-port/normal-mode port thunk)
+ (let ((operation (input-port/custom-operation port 'NORMAL-MODE)))
+ (if operation
+ (operation port thunk)
+ (thunk))))
-(define (input-port/read-finish! port)
- ((input-port/operation/read-finish! port) port))
+(define (input-port/immediate-mode port thunk)
+ (let ((operation (input-port/custom-operation port 'IMMEDIATE-MODE)))
+ (if operation
+ (operation port thunk)
+ (thunk))))
(define eof-object
"EOF Object")
(if (default-object? port)
(current-input-port)
(guarantee-input-port port))))
- (or (input-port/peek-char-immediate port)
+ (or (input-port/peek-char port)
eof-object)))
(define (read-char #!optional port)
(if (default-object? port)
(current-input-port)
(guarantee-input-port port))))
- (or (input-port/read-char-immediate port)
+ (or (input-port/read-char port)
eof-object)))
(define (read-char-no-hang #!optional port)
(current-input-port)
(guarantee-input-port port))))
(and (input-port/char-ready? port 0)
- (or (input-port/read-char-immediate port)
+ (or (input-port/read-char port)
eof-object))))
(define (read-string delimiters #!optional port)
(if (default-object? parser-table)
(current-parser-table)
(guarantee-parser-table parser-table))))
- (input-port/read-start! port)
+ (let ((read-start! (input-port/custom-operation port 'READ-START!)))
+ (if read-start!
+ (read-start! port)))
(let ((object (parse-object/internal port parser-table)))
- (input-port/read-finish! port)
+ (let ((read-finish! (input-port/custom-operation port 'READ-FINISH!)))
+ (if read-finish!
+ (read-finish! port)))
object)))
(define (close-input-port port)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.5 1990/04/10 20:05:13 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.6 1990/06/20 20:29:20 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. |#
-;;;; Input/output utilities
+;;;; Input/Output Utilities
;;; package: (runtime primitive-io)
(declare (usual-integrations))
\f
+(define open-channels-list)
+(define traversing?)
+
(define (initialize-package!)
- (set! close-all-open-files (close-files file-close-channel))
- (set! primitive-io/reset! (close-files (lambda (ignore) ignore)))
- (set! open-files-list (list 'OPEN-FILES-LIST))
+ (set! open-channels-list (list 'OPEN-CHANNELS-LIST))
(set! traversing? false)
(add-gc-daemon! close-lost-open-files-daemon)
(add-event-receiver! event:after-restore primitive-io/reset!)
(add-event-receiver! event:before-exit close-all-open-files))
-(define-integrable (make-physical-channel descriptor channel direction)
- (hunk3-cons descriptor channel direction))
-
-(define-integrable (channel-descriptor channel)
- (system-hunk3-cxr0 channel))
-
-(define-integrable (set-channel-descriptor! channel descriptor)
- (system-hunk3-set-cxr0! channel descriptor))
+(define-structure (channel (constructor %make-channel))
+ ;; This structure serves two purposes. First, because a descriptor
+ ;; is a non-pointer, it is necessary to store it in an allocated
+ ;; object in order to determine when all references to it have been
+ ;; dropped. Second, the structure provides a type predicate.
+ descriptor
+ (type false read-only true))
-(define-integrable (channel-name channel)
- (system-hunk3-cxr1 channel))
-
-(define-integrable (channel-direction channel)
- (system-hunk3-cxr2 channel))
+(define (make-channel descriptor)
+ ;; Make sure that interrupts are disabled before `descriptor' is
+ ;; created until after this procedure returns.
+ (let ((channel
+ (%make-channel
+ descriptor
+ (let ((type ((ucode-primitive channel-type 1) descriptor))
+ (types
+ '#(#F FILE PIPE FIFO TERMINAL PTY-MASTER
+ UNIX-STREAM-SOCKET TCP-STREAM-SOCKET)))
+ (and (< type (vector-length types))
+ (vector-ref types type))))))
+ (with-absolutely-no-interrupts
+ (lambda ()
+ (set-cdr! open-channels-list
+ (cons (system-pair-cons (ucode-type weak-cons)
+ channel
+ descriptor)
+ (cdr open-channels-list)))))
+ channel))
-(define-integrable (set-channel-direction! channel direction)
- (system-hunk3-set-cxr2! channel direction))
+(define (descriptor->channel descriptor)
+ (or (let loop ((channels (cdr open-channels-list)))
+ (and (not (null? channels))
+ (if (= descriptor (system-pair-cdr (car channels)))
+ (system-pair-car (car channels))
+ (loop (cdr channels)))))
+ (make-channel descriptor)))
-(define-primitives
- file-open-channel
- file-close-channel
- close-lost-open-files)
+(define-integrable (channel-type=file? channel)
+ (eq? 'FILE (channel-type channel)))
-(define-integrable closed-direction 0)
-(define-integrable closed-descriptor false)
+(define-integrable (channel-type=terminal? channel)
+ (eq? 'TERMINAL (channel-type channel)))
-(define open-files-list)
-(define traversing?)
+(define-integrable (channel-type=pty-master? channel)
+ (eq? 'PTY-MASTER (channel-type channel)))
\f
-;;;; Open/Close Files
-
-;;; Direction is one of the following:
-;;; - #f: input channel
-;;; - #t: output channel
-;;; - 'append: append output channel
-;;; - 0: closed channel
-
-(define (open-channel filename-or-process direction)
- (without-interrupts
- (lambda ()
- (let ((channel
- (case direction
- ((#F)
- (make-physical-channel
- (if (process? filename-or-process)
- (process-get-input-channel filename-or-process)
- (file-open-channel filename-or-process direction))
- filename-or-process
- direction))
- ((#T)
- (make-physical-channel
- (if (process? filename-or-process)
- (process-get-output-channel filename-or-process)
- (file-open-channel filename-or-process direction))
- filename-or-process
- direction))
- (else
- (if (process? filename-or-process)
- (error "Can't open process channel for append"
- filename-or-process))
- (make-physical-channel
- (file-open-channel filename-or-process 'APPEND)
- filename-or-process
- #T)))))
- (with-absolutely-no-interrupts
- (lambda ()
- (set-cdr! open-files-list
- (cons (system-pair-cons (ucode-type weak-cons)
- channel
- (channel-descriptor channel))
- (cdr open-files-list)))))
- channel))))
-
-(define (open-input-channel filename-or-process)
- (open-channel filename-or-process false))
-
-(define (open-output-channel filename-or-process)
- (open-channel filename-or-process true))
-
-(define (open-append-channel filename)
- (open-channel filename 'APPEND))
-\f
-;;; This is locked from interrupts, but GC can occur since the
-;;; procedure itself hangs on to the channel until the last moment,
-;;; when it returns the channel's name. The list will not be spliced
-;;; by the daemon behind its back because of the traversing? flag.
-
-(define (close-physical-channel channel)
+(define (channel-close channel)
+ ;; This is locked from interrupts, but GC can occur since the
+ ;; procedure itself hangs on to the channel until the last moment,
+ ;; when it returns the channel's name. The list will not be spliced
+ ;; by the daemon behind its back because of the traversing? flag.
(fluid-let ((traversing? true))
(without-interrupts
(lambda ()
- (if (eq? closed-direction (channel-direction channel))
- true ;Already closed!
+ (if (channel-descriptor channel)
(begin
- (file-close-channel (channel-descriptor channel))
- (set-channel-direction! channel closed-direction)
- (set-channel-descriptor! channel closed-descriptor)
+ ((ucode-primitive channel-close 1) (channel-descriptor channel))
+ (set-channel-descriptor! channel false)
(let loop
- ((l1 open-files-list)
- (l2 (cdr open-files-list)))
+ ((l1 open-channels-list)
+ (l2 (cdr open-channels-list)))
(cond ((null? l2)
(set! traversing? false)
- (error "CLOSE-PHYSICAL-CHANNEL: lost channel" channel))
+ (error "CHANNEL-CLOSE: lost channel" channel))
((eq? channel (system-pair-car (car l2)))
- (set-cdr! l1 (cdr l2))
- (channel-name channel))
+ (set-cdr! l1 (cdr l2)))
(else
(loop l2 (cdr l2)))))))))))
-\f
-;;;; Finalization and daemon.
-
-(define (close-files action)
- (lambda ()
- (fluid-let ((traversing? true))
- (without-interrupts
- (lambda ()
- (let loop ((l (cdr open-files-list)))
- (cond ((null? l) true)
- (else
- (let ((channel (system-pair-car (car l))))
- (if (not (eq? channel false))
- (begin
- (set-channel-descriptor! channel
- closed-descriptor)
- (set-channel-direction! channel
- closed-direction)))
- (action (system-pair-cdr (car l)))
- (set-cdr! open-files-list (cdr l)))
- (loop (cdr open-files-list))))))))))
-
-;;; This is invoked before disk-restoring. It "cleans" the microcode.
-(define close-all-open-files)
-
-;;; This is invoked after disk-restoring. It "cleans" the new runtime system.
-(define primitive-io/reset!)
-\f
+
+(define (close-all-open-files)
+ ;; This is invoked before disk-restoring. It "cleans" the microcode. (close-all-open-files-internal (ucode-primitive channel-close 1)))
+
+(define (primitive-io/reset!)
+ ;; This is invoked after disk-restoring. It "cleans" the new runtime system.
+ (close-all-open-files-internal (lambda (ignore) ignore)))
+
+(define (close-all-open-files-internal action)
+ (fluid-let ((traversing? true))
+ (without-interrupts
+ (lambda ()
+ (let loop ((l (cdr open-channels-list)))
+ (if (not (null? l))
+ (begin
+ (let ((channel (system-pair-car (car l))))
+ (if channel
+ (set-channel-descriptor! channel false)))
+ (action (system-pair-cdr (car l)))
+ (let ((l (cdr l)))
+ (set-cdr! open-channels-list l)
+ (loop l)))))))))
+
;;; This is the daemon which closes files which no one points to.
;;; Runs with GC, and lower priority interrupts, disabled.
;;; It is unsafe because of the (unnecessary) consing by the
#|
(define (close-lost-open-files-daemon)
(if (not traversing?)
- (let loop ((l1 open-files-list) (l2 (cdr open-files-list)))
+ (let loop ((l1 open-channels-list) (l2 (cdr open-channels-list)))
(cond ((null? l2)
true)
- ((null? (system-pair-car (car l2)))
- (file-close-channel (system-pair-cdr (car l2)))
- (set-cdr! l1 (cdr l2))
- (loop l1 (cdr l1)))
+ ((system-pair-car (car l2))
+ (loop l2 (cdr l2)))
(else
- (loop l2 (cdr l2)))))))
+ ((ucode-primitive channel-close 1) (system-pair-cdr (car l2)))
+ (set-cdr! l1 (cdr l2))
+ (loop l1 (cdr l1)))))))
|#
(define (close-lost-open-files-daemon)
(if (not traversing?)
- (close-lost-open-files open-files-list)))
\ No newline at end of file
+ ((ucode-primitive close-lost-open-files 1) open-channels-list)))
+\f
+;;;; Wrapped Primitives
+
+(define (channel-read channel buffer start end)
+ ((ucode-primitive channel-read 4) (channel-descriptor channel)
+ buffer start end))
+
+(define (channel-read-block channel buffer start end)
+ (let loop ()
+ (or (channel-read channel buffer start end)
+ (loop))))
+
+(define (channel-write channel buffer start end)
+ ((ucode-primitive channel-write 4) (channel-descriptor channel)
+ buffer start end))
+
+(define (channel-write-block channel buffer start end)
+ (let loop ((start start) (n-left (- end start)))
+ (let ((n (channel-write channel buffer start end)))
+ (cond ((not n) (loop start n-left))
+ ((< n n-left) (loop (+ start n) (- n-left n)))))))
+
+(define (channel-write-string-block channel string)
+ (channel-write-block channel string 0 (string-length string)))
+
+(define (channel-write-char-block channel char)
+ (channel-write-block channel (string char) 0 1))
+
+(define (channel-blocking? channel)
+ ((ucode-primitive channel-blocking? 1) (channel-descriptor channel)))
+
+(define (channel-blocking channel)
+ ((ucode-primitive channel-blocking 1) (channel-descriptor channel)))
+
+(define (channel-nonblocking channel)
+ ((ucode-primitive channel-nonblocking 1) (channel-descriptor channel)))
+
+(define (with-channel-blocking channel blocking? thunk)
+ (let ((blocking-outside?))
+ (dynamic-wind
+ (lambda ()
+ (set! blocking-outside? (channel-blocking? channel))
+ (if blocking?
+ (channel-blocking channel)
+ (channel-nonblocking channel)))
+ thunk
+ (lambda ()
+ (set! blocking? (channel-blocking? channel))
+ (if blocking-outside?
+ (channel-blocking channel)
+ (channel-nonblocking channel))))))
+
+(define (channel-table)
+ (fluid-let ((traversing? true))
+ (without-interrupts
+ (lambda ()
+ (let ((descriptors ((ucode-primitive channel-table 0))))
+ (and descriptors
+ (vector-map descriptors descriptor->channel)))))))
+\f
+(define (file-open-input-channel filename)
+ (without-interrupts
+ (lambda ()
+ (make-channel ((ucode-primitive file-open-input-channel 1) filename)))))
+
+(define (file-open-output-channel filename)
+ ((ucode-primitive file-remove-link 1) filename)
+ (without-interrupts
+ (lambda ()
+ (make-channel ((ucode-primitive file-open-output-channel 1) filename)))))
+
+(define (file-open-io-channel filename)
+ (without-interrupts
+ (lambda ()
+ (make-channel ((ucode-primitive file-open-io-channel 1) filename)))))
+
+(define (file-open-append-channel filename)
+ (without-interrupts
+ (lambda ()
+ (make-channel ((ucode-primitive file-open-append-channel 1) filename)))))
+
+(define (tty-input-channel)
+ (without-interrupts
+ (lambda ()
+ (make-channel ((ucode-primitive tty-input-channel 0))))))
+
+(define (tty-output-channel)
+ (without-interrupts
+ (lambda ()
+ (make-channel ((ucode-primitive tty-output-channel 0))))))
+
+(define (file-length channel)
+ ((ucode-primitive file-length-new 1) (channel-descriptor channel)))
+
+(define (file-position channel)
+ ((ucode-primitive file-position 1) (channel-descriptor channel)))
+
+(define (file-set-position channel position)
+ ((ucode-primitive file-set-position 2) (channel-descriptor channel)
+ position))
+
+(define (terminal-read-char channel)
+ ((ucode-primitive terminal-read-char 1) (channel-descriptor channel)))
+
+(define (terminal-char-ready? channel delay)
+ ((ucode-primitive terminal-char-ready? 2) (channel-descriptor channel)
+ delay))
+
+(define (terminal-buffered? channel)
+ ((ucode-primitive terminal-buffered? 1) (channel-descriptor channel)))
+
+(define (terminal-buffered channel)
+ ((ucode-primitive terminal-buffered 1) (channel-descriptor channel)))
+
+(define (terminal-nonbuffered channel)
+ ((ucode-primitive terminal-nonbuffered 1) (channel-descriptor channel)))
+
+(define (terminal-flush-input channel)
+ ((ucode-primitive terminal-flush-input 1) (channel-descriptor channel)))
+
+(define (terminal-flush-output channel)
+ ((ucode-primitive terminal-flush-output 1) (channel-descriptor channel)))
+
+(define (terminal-drain-output channel)
+ ((ucode-primitive terminal-drain-output 1) (channel-descriptor channel)))
+
+(define (open-pty-master)
+ (without-interrupts
+ (lambda ()
+ (let ((result ((ucode-primitive open-pty-master 0))))
+ (if (not result)
+ (error "unable to open pty master"))
+ (values (make-channel (vector-ref result 0))
+ (vector-ref result 1)
+ (vector-ref result 2))))))
+
+(define (pty-master-send-signal channel signal)
+ ((ucode-primitive pty-master-send-signal 2) (channel-descriptor channel)
+ signal))
+\f
+;;;; File Copying
+
+(define (copy-file from to)
+ (file-copy (canonicalize-input-filename from)
+ (canonicalize-output-filename to)))
+
+(define (file-copy input-filename output-filename)
+ (let ((input-channel false)
+ (output-channel false))
+ (dynamic-wind
+ (lambda ()
+ (set! input-channel (file-open-input-channel input-filename))
+ (set! output-channel (file-open-output-channel output-filename)))
+ (lambda ()
+ (let ((source-length (file-length input-channel))
+ (buffer-length 8192))
+ (if (zero? source-length)
+ 0
+ (let* ((buffer (make-string buffer-length))
+ (transfer
+ (lambda (length)
+ (let ((n-read
+ (channel-read-block input-channel
+ buffer
+ 0
+ length)))
+ (if (positive? n-read)
+ (channel-write-block output-channel
+ buffer
+ 0
+ n-read))
+ n-read))))
+ (let loop ((source-length source-length))
+ (if (< source-length buffer-length)
+ (transfer source-length)
+ (let ((n-read (transfer buffer-length)))
+ (if (= n-read buffer-length)
+ (+ (loop (- source-length buffer-length))
+ buffer-length)
+ n-read))))))))
+ (lambda ()
+ (if output-channel (channel-close output-channel))
+ (if input-channel (channel-close input-channel))))))
+\f
+;;;; Buffered Output
+
+(define-structure (output-buffer
+ (conc-name output-buffer/)
+ (constructor %make-output-buffer))
+ (channel false read-only true)
+ string
+ position)
+
+(define-integrable (make-output-buffer channel buffer-size)
+ (%make-output-buffer channel (make-string buffer-size) 0))
+
+(define (output-buffer/close buffer)
+ (output-buffer/drain-block buffer)
+ (channel-close (output-buffer/channel buffer)))
+
+(define (output-buffer/size buffer)
+ (string-length (output-buffer/string buffer)))
+
+(define (output-buffer/set-size buffer buffer-size)
+ (if (> (output-buffer/position buffer) buffer-size)
+ (let loop () (if (>= (output-buffer/drain buffer) buffer-size) (loop))))
+ (let ((position (output-buffer/position buffer))
+ (string (make-string buffer-size)))
+ (substring-move-left! (output-buffer/string buffer) 0 position string 0)
+ (set-output-buffer/string! buffer string)
+ (if (= position buffer-size) (output-buffer/drain buffer))))
+
+(define (output-buffer/drain buffer)
+ (let ((position (output-buffer/position buffer)))
+ (if (zero? position)
+ 0
+ (let ((channel (output-buffer/channel buffer))
+ (string (output-buffer/string buffer)))
+ (let ((n (channel-write channel string 0 position)))
+ (cond ((or (not n) (zero? n)) position)
+ ((< n position)
+ (let ((position* (- position n)))
+ (substring-move-left! string n position string 0)
+ (set-output-buffer/position! buffer position*)
+ position*))
+ (else
+ (set-output-buffer/position! buffer 0)
+ 0)))))))
+
+(define (output-buffer/flush buffer)
+ (set-output-buffer/position! buffer 0))
+
+(define (output-buffer/write-substring buffer string start end)
+ (if (= start end)
+ 0
+ (let loop ((start start) (n-left (- end start)) (n-previous 0))
+ (let ((string* (output-buffer/string buffer))
+ (position (output-buffer/position buffer)))
+ (let ((length (string-length string*))
+ (position* (+ position n-left)))
+ (cond ((<= position* length)
+ (substring-move-left! string start end string* position)
+ (set-output-buffer/position! buffer position*)
+ (if (= position* length) (output-buffer/drain buffer))
+ (+ n-previous n-left))
+ ((< position length)
+ (let ((room (- length position)))
+ (let ((end (+ start room))
+ (n-previous (+ n-previous room)))
+ (substring-move-left! string start end string* position)
+ (set-output-buffer/position! buffer length)
+ (if (< (output-buffer/drain buffer) length)
+ (loop end (- n-left room) n-previous)
+ n-previous))))
+ (else
+ (if (< (output-buffer/drain buffer) length)
+ (loop start n-left n-previous)
+ n-previous))))))))
+
+(define (output-buffer/write-char buffer char)
+ (let* ((string (output-buffer/string buffer))
+ (length (string-length string)))
+ (and (or (< (output-buffer/position buffer) length)
+ (< (output-buffer/drain buffer) length))
+ (let ((position (output-buffer/position buffer)))
+ (string-set! string position char)
+ (let ((position (1+ position)))
+ (set-output-buffer/position! buffer position)
+ (if (= position length) (output-buffer/drain buffer))
+ true)))))
+
+(define (output-buffer/drain-block buffer)
+ (let loop ()
+ (if (not (zero? (output-buffer/drain buffer)))
+ (loop))))
+
+(define (output-buffer/write-string-block buffer string)
+ (output-buffer/write-substring-block buffer string 0 (string-length string)))
+
+(define (output-buffer/write-substring-block buffer string start end)
+ (let loop ((start start) (n-left (- end start)))
+ (let ((n (output-buffer/write-substring buffer string start end)))
+ (if (< n n-left)
+ (loop (+ start n) (- n-left n))))))
+
+(define (output-buffer/write-char-block buffer char)
+ (let loop ()
+ (if (not (output-buffer/write-char buffer char))
+ (loop))))
+\f
+;;;; Buffered Input
+
+(define-structure (input-buffer
+ (conc-name input-buffer/)
+ (constructor %make-input-buffer))
+ (channel false read-only true)
+ string
+ start-index
+ end-index)
+
+(define (make-input-buffer channel buffer-size)
+ (%make-input-buffer channel
+ (make-string buffer-size)
+ buffer-size
+ buffer-size))
+
+(define (input-buffer/close buffer)
+ (set-input-buffer/end-index! buffer 0)
+ (channel-close (input-buffer/channel buffer)))
+
+(define (input-buffer/size buffer)
+ (string-length (input-buffer/string buffer)))
+
+(define (input-buffer/set-size buffer buffer-size)
+ ;; If the buffer's contents will not fit with the new size, the
+ ;; oldest part of it is discarded.
+ (let ((start-index (input-buffer/start-index buffer))
+ (end-index (input-buffer/end-index buffer))
+ (string (make-string buffer-size)))
+ (substring-move-left! (input-buffer/string buffer)
+ (max start-index (- end-index buffer-size))
+ end-index
+ string
+ 0)
+ (set-input-buffer/string! buffer string)
+ (set-input-buffer/start-index! buffer 0)
+ (set-input-buffer/end-index! buffer (- end-index start-index))))
+
+(define (input-buffer/flush buffer)
+ (let ((end-index (input-buffer/end-index buffer)))
+ (if (< (input-buffer/start-index buffer) end-index)
+ (set-input-buffer/start-index! buffer end-index))))
+
+(define (input-buffer/chars-available buffer)
+ (- (input-buffer/end-index buffer) (input-buffer/start-index buffer)))
+
+(define (input-buffer/chars-remaining buffer)
+ (let ((channel (input-buffer/channel buffer)))
+ (and (channel-type=file? channel)
+ (let ((n (- (file-length channel) (file-position channel))))
+ (and (not (negative? n))
+ (+ (input-buffer/chars-available buffer) n))))))
+
+(define (input-buffer/char-ready? buffer)
+ (char-ready? buffer
+ (lambda (buffer)
+ (case (channel-blocking? (input-buffer/channel buffer))
+ ((#F)
+ (input-buffer/fill buffer))
+ ((#T)
+ (with-channel-blocking (input-buffer/channel buffer)
+ false
+ (lambda () (input-buffer/fill buffer))))
+ (else false)))))
+
+(define (char-ready? buffer fill)
+ (let ((end-index (input-buffer/end-index buffer)))
+ (cond ((< (input-buffer/start-index buffer) end-index) true)
+ ((zero? (input-buffer/end-index buffer)) false)
+ (else (fill buffer)))))
+\f
+(define (input-buffer/fill buffer)
+ (let ((end-index
+ (let ((string (input-buffer/string buffer)))
+ (channel-read (input-buffer/channel buffer)
+ string 0 (string-length string)))))
+ (and end-index
+ (begin
+ (set-input-buffer/start-index! buffer 0)
+ (set-input-buffer/end-index! buffer end-index)
+ (not (zero? end-index))))))
+
+(define (input-buffer/read-char buffer)
+ (let ((start-index (input-buffer/start-index buffer))
+ (end-index (input-buffer/end-index buffer)))
+ (if (< start-index end-index)
+ (begin
+ (set-input-buffer/start-index! buffer (1+ start-index))
+ (string-ref (input-buffer/string buffer) start-index))
+ (and (not (zero? end-index))
+ (input-buffer/fill buffer)
+ (begin
+ (set-input-buffer/start-index! buffer 1)
+ (string-ref (input-buffer/string buffer) 0))))))
+
+(define (input-buffer/peek-char buffer)
+ (let ((start-index (input-buffer/start-index buffer))
+ (end-index (input-buffer/end-index buffer)))
+ (if (< start-index end-index)
+ (string-ref (input-buffer/string buffer) start-index)
+ (and (not (zero? end-index))
+ (input-buffer/fill buffer)
+ (string-ref (input-buffer/string buffer) 0)))))
+
+(define (input-buffer/discard-char buffer)
+ (let ((start-index (input-buffer/start-index buffer)))
+ (if (< start-index (input-buffer/end-index buffer))
+ (set-input-buffer/start-index! buffer (1+ start-index)))))
+
+(define (input-buffer/read-substring buffer string start end)
+ (let ((start-index (input-buffer/start-index buffer))
+ (end-index (input-buffer/end-index buffer)))
+ (cond ((< start-index end-index)
+ (let ((string* (input-buffer/string buffer))
+ (available (- end-index start-index))
+ (needed (- end start)))
+ (if (>= available needed)
+ (begin
+ (let ((end-index (+ start-index needed)))
+ (substring-move-left! string* start-index end-index
+ string start)
+ (set-input-buffer/start-index! buffer end-index))
+ needed)
+ (begin
+ (substring-move-left! string* start-index end-index
+ string start)
+ (set-input-buffer/start-index! buffer end-index)
+ (+ available
+ (or (channel-read (input-buffer/channel buffer)
+ string
+ (+ start available)
+ end)
+ 0))))))
+ ((zero? end-index)
+ 0)
+ (else
+ (channel-read (input-buffer/channel buffer) string start end)))))
+\f
+(define (input-buffer/read-until-delimiter buffer delimiters)
+ (and (char-ready? buffer input-buffer/fill)
+ (let ((string (input-buffer/string buffer)))
+ (let loop ()
+ (let ((start-index (input-buffer/start-index buffer))
+ (end-index (input-buffer/end-index buffer)))
+ (let ((delimiter-index
+ (substring-find-next-char-in-set string
+ start-index
+ end-index
+ delimiters)))
+ (if delimiter-index
+ (let ((head (substring string start-index delimiter-index)))
+ (set-input-buffer/start-index! buffer delimiter-index)
+ head)
+ (let ((head (substring string start-index end-index)))
+ (set-input-buffer/start-index! buffer end-index)
+ (if (input-buffer/fill buffer)
+ (string-append head (loop))
+ head)))))))))
+
+(define (input-buffer/discard-until-delimiter buffer delimiters)
+ (if (char-ready? buffer input-buffer/fill)
+ (let ((string (input-buffer/string buffer)))
+ (let loop ()
+ (let ((end-index (input-buffer/end-index buffer)))
+ (let ((delimiter-index
+ (substring-find-next-char-in-set
+ string
+ (input-buffer/start-index buffer)
+ end-index
+ delimiters)))
+ (if delimiter-index
+ (set-input-buffer/start-index! buffer delimiter-index)
+ (begin
+ (set-input-buffer/start-index! buffer end-index)
+ (if (input-buffer/fill buffer)
+ (loop))))))))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.16 1990/06/04 20:46:42 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.17 1990/06/20 20:29:26 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
\f
(define (load/internal pathname true-pathname environment syntax-table
purify? load-noisily?)
- (let* ((true-filename (pathname->string true-pathname))
- (port (open-input-file/internal pathname true-filename))
+ (let* ((port (open-input-file/internal pathname true-pathname))
(fasl-marker (peek-char port)))
(if (and (not (eof-object? fasl-marker))
(= 250 (char->ascii fasl-marker)))
(write-stream (value-stream)
(lambda (value)
(hook/repl-write (nearest-repl) value)))
- (loading-message load/suppress-loading-message? true-filename
+ (loading-message load/suppress-loading-message?
+ (pathname->string true-pathname)
(lambda ()
(write-stream (value-stream)
(lambda (value)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.21 1990/02/27 19:44:26 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.22 1990/06/20 20:29:31 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(let ((environment-for-package (let () (the-environment))))
(define-primitives
- (+ &+)
+ (+ integer-add)
+ (- integer-subtract)
+ (< integer-less?)
binary-fasload
+ (channel-write 4)
environment-link-name
exit
(file-exists? 1)
substring=?
substring-move-right!
substring-downcase!
- tty-flush-output
- tty-write-char
- tty-write-string
+ (tty-output-channel 0)
vector-ref
vector-set!
with-interrupt-mask)
-(define microcode-identification
- (microcode-identify))
+(define microcode-identification (microcode-identify))
+(define newline-char (vector-ref microcode-identification 5))
+(define os-name-string (vector-ref microcode-identification 8))
+(define tty-output-descriptor (tty-output-channel))
-(define newline-char
- (vector-ref microcode-identification 5))
+(define (tty-write-string string)
+ (let ((end (string-length string)))
+ (let loop ((start 0) (n-left end))
+ (let ((n (channel-write tty-output-descriptor string start end)))
+ (cond ((not n) (loop start n-left))
+ ((< n n-left) (loop (+ start n) (- n-left n))))))))
-(define os-name-string
- (vector-ref microcode-identification 8))
+(define (tty-write-char char)
+ (tty-write-string
+ (let ((string (string-allocate 1)))
+ (string-set! string 0 char)
+ string)))
(define (fatal-error message)
(tty-write-char newline-char)
(tty-write-string message)
(tty-write-char newline-char)
- (tty-flush-output)
(exit))
\f
;;;; GC, Interrupts, Errors
(define (fasload filename purify?)
(tty-write-char newline-char)
(tty-write-string filename)
- (tty-flush-output)
(let ((value (binary-fasload filename)))
(tty-write-string " loaded")
- (tty-flush-output)
(if purify?
(set! fasload-purification-queue
(cons (cons filename value)
(define (eval object environment)
(let ((value (scode-eval object environment)))
(tty-write-string " evaluated")
- (tty-flush-output)
value))
(define (package-initialize package-name procedure-name)
(tty-write-string " [")
(tty-write-string (system-pair-car procedure-name))
(tty-write-string "]")))
- (tty-flush-output)
((lexical-reference (package-reference package-name) procedure-name)))
(define (package-reference name)
;; I/O
(RUNTIME CONSOLE-INPUT)
(RUNTIME CONSOLE-OUTPUT)
+ (RUNTIME TRANSCRIPT)
(RUNTIME FILE-INPUT)
(RUNTIME FILE-OUTPUT)
(RUNTIME STRING-INPUT)
(RUNTIME TRUNCATED-STRING-OUTPUT)
(RUNTIME INPUT-PORT)
(RUNTIME OUTPUT-PORT)
- (RUNTIME SUBPROCESSES)
- (RUNTIME SUBPROCESSES INPUT)
- (RUNTIME SUBPROCESSES OUTPUT)
(RUNTIME WORKING-DIRECTORY)
(RUNTIME DIRECTORY)
(RUNTIME LOAD)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 14.5 1989/03/06 19:58:24 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/output.scm,v 14.6 1990/06/20 20:29:39 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(operation/write-char false read-only true)
(operation/write-string false read-only true)
(operation/flush-output false read-only true)
- (custom-operations false read-only true))
+ (custom-operations false read-only true)
+ (operation-names false read-only true))
(define (guarantee-output-port port)
(if (not (output-port? port)) (error "Bad output port" port))
(flush-output
(operation 'FLUSH-OUTPUT default-operation/flush-output)))
(%make-output-port state write-char write-string flush-output
- operations)))))
+ operations
+ (append '(WRITE-CHAR WRITE-STRING FLUSH-OUTPUT)
+ (map car operations)))))))
(define (default-operation/write-string port string)
(let ((write-char (output-port/operation/write-char port))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.6 1989/08/12 08:18:23 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.7 1990/06/20 20:29:44 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
\f
;;;; Truenames
+(define (canonicalize-input-filename filename)
+ (pathname->string (canonicalize-input-pathname filename)))
+
+(define (canonicalize-input-pathname filename)
+ (let ((pathname (->pathname filename)))
+ (let ((truename (pathname->input-truename pathname)))
+ (if (not truename) (error error-type:open-file pathname))
+ truename)))
+
(define (pathname->input-truename pathname)
(let ((pathname (pathname->absolute-pathname pathname))
(truename-exists?
(else
(pathname-newest pathname)))))
+(define (canonicalize-output-filename filename)
+ (pathname->string (canonicalize-output-pathname filename)))
+
+(define-integrable (canonicalize-output-pathname filename)
+ (pathname->output-truename (->pathname filename)))
+
(define (pathname->output-truename pathname)
(let ((pathname (pathname->absolute-pathname pathname)))
(if (eq? 'NEWEST (pathname-version pathname))
1))))
pathname)))
-(define (canonicalize-input-filename filename)
- (let ((pathname (->pathname filename)))
- (let ((truename (pathname->input-truename pathname)))
- (if (not truename) (error error-type:open-file pathname))
- (pathname->string truename))))
+(define (canonicalize-overwrite-filename filename)
+ (pathname->string (canonicalize-overwrite-pathname filename)))
-(define (canonicalize-output-filename filename)
- (pathname->string (pathname->output-truename (->pathname filename))))
+(define-integrable (canonicalize-overwrite-pathname filename)
+ (pathname->overwrite-truename (->pathname filename)))
+
+(define (pathname->overwrite-truename pathname)
+ (let ((pathname (pathname->absolute-pathname pathname)))
+ (cond ((not (eq? 'NEWEST (pathname-version pathname)))
+ pathname)
+ ((not pathname-newest)
+ (pathname-new-version pathname false))
+ ((pathname-newest pathname))
+ (else
+ (pathname-new-version pathname 1)))))
(define (file-exists? filename)
(pathname->input-truename (->pathname filename)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.13 1989/10/26 06:46:50 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.14 1990/06/20 20:29:50 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(define (make-repl parent environment syntax-table prompt input-port
output-port message)
- (make-cmdl parent
- input-port
- output-port
- repl-driver
- (make-repl-state prompt
- environment
- syntax-table
- (make-repl-history reader-history-size)
- (make-repl-history printer-history-size))
- (cmdl-message/append
- message
- (cmdl-message/active
- (lambda ()
- (hook/repl-environment (nearest-repl) environment))))))
+ (input-port/normal-mode input-port
+ (lambda ()
+ (make-cmdl parent
+ input-port
+ output-port
+ repl-driver
+ (make-repl-state prompt
+ environment
+ syntax-table
+ (make-repl-history reader-history-size)
+ (make-repl-history printer-history-size))
+ (cmdl-message/append
+ message
+ (cmdl-message/active
+ (lambda ()
+ (hook/repl-environment (nearest-repl) environment))))))))
(define (repl-driver repl)
(fluid-let ((hook/error-handler default/error-handler))
(define (default/prompt-for-confirmation cmdl prompt)
(let ((input-port (cmdl/input-port cmdl))
(output-port (cmdl/output-port cmdl)))
- (let loop ()
- (newline output-port)
- (write-string prompt output-port)
- (write-string " (y or n)? " output-port)
- (let ((char (char-upcase (read-char-internal input-port))))
- (cond ((or (char=? #\Y char)
- (char=? #\Space char))
- (write-string "Yes" output-port)
- true)
- ((or (char=? #\N char)
- (char=? #\Rubout char))
- (write-string "No" output-port)
- false)
- (else
- (beep output-port)
- (loop)))))))
+ (input-port/immediate-mode input-port
+ (lambda ()
+ (let loop ()
+ (newline output-port)
+ (write-string prompt output-port)
+ (write-string " (y or n)? " output-port)
+ (let ((char (char-upcase (read-char-internal input-port))))
+ (cond ((or (char=? #\Y char)
+ (char=? #\Space char))
+ (write-string "Yes" output-port)
+ true)
+ ((or (char=? #\N char)
+ (char=? #\Rubout char))
+ (write-string "No" output-port)
+ false)
+ (else
+ (beep output-port)
+ (loop)))))))))
(define (default/prompt-for-expression cmdl prompt)
- (let ((output-port (cmdl/output-port cmdl)))
+ (let ((input-port (cmdl/input-port cmdl))
+ (output-port (cmdl/output-port cmdl)))
(newline output-port)
(write-string prompt output-port)
(write-string ": " output-port)
- (read (cmdl/input-port cmdl))))
+ (input-port/normal-mode input-port
+ (lambda ()
+ (read input-port)))))
(define (read-char-internal input-port)
(let loop ()
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.66 1990/04/21 16:26:47 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.67 1990/06/20 20:29:56 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(export ()
console-input-port)
(export (runtime emacs-interface)
- hook/read-char-immediate
hook/read-finish
hook/read-start)
(initialization (initialize-package!)))
open-output-file)
(initialization (initialize-package!)))
+(define-package (runtime transcript)
+ (files "tscript")
+ (parent ())
+ (export ()
+ transcript-off
+ transcript-on)
+ (export (runtime console-input)
+ transcript-port)
+ (export (runtime console-output)
+ transcript-port)
+ (initialization (initialize-package!)))
+
(define-package (runtime format)
(file-case options
((load) "format")
input-port/discard-char
input-port/discard-chars
input-port/operation
+ input-port/operation-names
input-port/operation/char-ready?
input-port/operation/discard-char
input-port/operation/discard-chars
input-port/operation/peek-char
- input-port/operation/peek-char-immediate
input-port/operation/read-char
- input-port/operation/read-char-immediate
- input-port/operation/read-finish!
- input-port/operation/read-start!
input-port/operation/read-string
+ input-port/immediate-mode
+ input-port/normal-mode
input-port/peek-char
- input-port/peek-char-immediate
input-port/read-char
- input-port/read-char-immediate
- input-port/read-finish!
- input-port/read-start!
input-port/read-string
input-port/state
input-port?
error-type:file
error-type:illegal-argument
error-type:open-file
+ error-type:premature-write-termination
error-type:random-internal
error-type:wrong-type-argument
microcode-error-type)
output-port/custom-operation
output-port/flush-output
output-port/operation
+ output-port/operation-names
output-port/operation/flush-output
output-port/operation/write-char
output-port/operation/write-string
(export (runtime macros)
lambda-optional-tag)
(export (runtime unsyntaxer)
- lambda-optional-tag)
+ lambda-optional-tag
+ lambda-rest-tag)
(export (runtime parser-table)
collect-list-wrapper)
(initialization (initialize-package!)))
(export ()
->pathname
canonicalize-input-filename
+ canonicalize-input-pathname
canonicalize-output-filename
+ canonicalize-output-pathname
+ canonicalize-overwrite-filename
+ canonicalize-overwrite-pathname
file-exists?
init-file-truename
make-pathname
(files "io")
(parent ())
(export ()
- close-all-open-files)
+ close-all-open-files
+ copy-file)
(export (runtime file-input)
- channel-name
- close-physical-channel
- open-input-channel)
+ file-length
+ file-open-input-channel
+ input-buffer/channel
+ input-buffer/char-ready?
+ input-buffer/chars-remaining
+ input-buffer/close
+ input-buffer/discard-char
+ input-buffer/discard-until-delimiter
+ input-buffer/peek-char
+ input-buffer/read-char
+ input-buffer/read-substring
+ input-buffer/read-until-delimiter
+ make-input-buffer)
(export (runtime file-output)
- channel-name
- close-physical-channel
- open-append-channel
- open-output-channel)
- (export (runtime subprocesses input)
- close-physical-channel
- open-input-channel)
- (export (runtime subprocesses output)
- close-physical-channel
- open-output-channel)
+ channel-close
+ channel-write-char-block
+ channel-write-string-block
+ file-open-append-channel
+ file-open-output-channel
+ make-output-buffer
+ output-buffer/close
+ output-buffer/drain-block
+ output-buffer/set-size
+ output-buffer/size
+ output-buffer/write-char-block
+ output-buffer/write-string-block)
+ (export (runtime console-output)
+ channel-write-char-block
+ channel-write-string-block
+ make-output-buffer
+ output-buffer/drain-block
+ output-buffer/set-size
+ output-buffer/size
+ output-buffer/write-char-block
+ output-buffer/write-string-block
+ tty-output-channel)
+ (export (runtime console-input)
+ channel-type=terminal?
+ input-buffer/char-ready?
+ input-buffer/read-char
+ make-input-buffer
+ terminal-buffered
+ terminal-buffered?
+ terminal-char-ready?
+ terminal-nonbuffered
+ terminal-read-char
+ tty-input-channel)
(initialization (initialize-package!)))
(define-package (runtime random-number)
make-unassigned?
sequence-actions
sequence-components
+ sequence-immediate-actions
sequence?
unassigned?-components
unassigned?-name
working-directory-pathname)
(export (runtime emacs-interface)
hook/set-working-directory-pathname!)
- (initialization (initialize-package!)))
-
-(define-package (runtime subprocesses)
- (files "process")
- (parent ())
- (export ()
- create-process
- delete-process
- kill-process
- process?
- process/command-string
- process/microcode-process
- process/to-port
- process/from-port
- process-get-pid
- process-get-input-channel
- process-get-output-channel
- process-get-status-flags
- prim-process-char-ready?)
- (initialization (initialize-package!)))
-
-(define-package (runtime subprocesses input)
- (files "procin")
- (parent ())
- (export ()
- open-process-input)
- (initialization (initialize-package!)))
-
-(define-package (runtime subprocesses output)
- (files "procout")
- (parent ())
- (export ()
- open-process-output)
(initialization (initialize-package!)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sfile.scm,v 14.3 1989/03/14 02:18:01 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/sfile.scm,v 14.4 1990/06/20 20:30:05 cph Rel $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
;;; package: ()
(declare (usual-integrations))
-\f
-(define (copy-file from to)
- ((ucode-primitive copy-file) (canonicalize-input-filename from)
- (canonicalize-output-filename to)))
(define (rename-file from to)
((ucode-primitive rename-file) (canonicalize-input-filename from)
(and truename
(begin
((ucode-primitive remove-file) (pathname->string truename))
- true))))
-
-(define (transcript-on filename)
- (if (not ((ucode-primitive photo-open)
- (canonicalize-output-filename filename)))
- (error "TRANSCRIPT-ON: Transcript file already open" filename))
- unspecific)
-
-(define (transcript-off)
- (if (not ((ucode-primitive photo-close)))
- (error "TRANSCRIPT-OFF: Transcript file already closed"))
- unspecific)
\ No newline at end of file
+ true))))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.16 1990/04/21 16:25:12 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uenvir.scm,v 14.17 1990/06/20 20:30:24 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(dbg-block/find-name block name)))))
(define (assign-dbg-variable! block name get-value value)
- (let ((index (dbg-block/find-name block name))
- (variable (vector-ref (dbg-block/layout-vector block) index)))
+ (let* ((index (dbg-block/find-name block name))
+ (variable (vector-ref (dbg-block/layout-vector block) index)))
(case (dbg-variable/type variable)
((CELL)
(let ((cell (get-value index)))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.13 1990/02/21 23:24:25 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.14 1990/06/20 20:30:31 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(define error-type:failed-argument-coercion)
(define error-type:fasdump)
(define error-type:fasload)
-(define error-type:illegal-argument)
(define error-type:file)
+(define error-type:illegal-argument)
(define error-type:open-file)
+(define error-type:premature-write-termination)
(define error-type:random-internal)
(define error-type:wrong-type-argument)
(make-condition-type (list error-type:file) "Fasdump error"))
(set! error-type:fasload
(make-condition-type (list error-type:file) "Fasload error"))
+ (set! error-type:premature-write-termination
+ (make-condition-type (list error-type:file)
+ "Channel write terminated prematurely"))
(set! error-type:anomalous
(make-internal-type "Anomalous microcode error")))
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.16 1990/06/04 20:46:42 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.17 1990/06/20 20:29:26 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
\f
(define (load/internal pathname true-pathname environment syntax-table
purify? load-noisily?)
- (let* ((true-filename (pathname->string true-pathname))
- (port (open-input-file/internal pathname true-filename))
+ (let* ((port (open-input-file/internal pathname true-pathname))
(fasl-marker (peek-char port)))
(if (and (not (eof-object? fasl-marker))
(= 250 (char->ascii fasl-marker)))
(write-stream (value-stream)
(lambda (value)
(hook/repl-write (nearest-repl) value)))
- (loading-message load/suppress-loading-message? true-filename
+ (loading-message load/suppress-loading-message?
+ (pathname->string true-pathname)
(lambda ()
(write-stream (value-stream)
(lambda (value)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.21 1990/02/27 19:44:26 markf Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.22 1990/06/20 20:29:31 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(let ((environment-for-package (let () (the-environment))))
(define-primitives
- (+ &+)
+ (+ integer-add)
+ (- integer-subtract)
+ (< integer-less?)
binary-fasload
+ (channel-write 4)
environment-link-name
exit
(file-exists? 1)
substring=?
substring-move-right!
substring-downcase!
- tty-flush-output
- tty-write-char
- tty-write-string
+ (tty-output-channel 0)
vector-ref
vector-set!
with-interrupt-mask)
-(define microcode-identification
- (microcode-identify))
+(define microcode-identification (microcode-identify))
+(define newline-char (vector-ref microcode-identification 5))
+(define os-name-string (vector-ref microcode-identification 8))
+(define tty-output-descriptor (tty-output-channel))
-(define newline-char
- (vector-ref microcode-identification 5))
+(define (tty-write-string string)
+ (let ((end (string-length string)))
+ (let loop ((start 0) (n-left end))
+ (let ((n (channel-write tty-output-descriptor string start end)))
+ (cond ((not n) (loop start n-left))
+ ((< n n-left) (loop (+ start n) (- n-left n))))))))
-(define os-name-string
- (vector-ref microcode-identification 8))
+(define (tty-write-char char)
+ (tty-write-string
+ (let ((string (string-allocate 1)))
+ (string-set! string 0 char)
+ string)))
(define (fatal-error message)
(tty-write-char newline-char)
(tty-write-string message)
(tty-write-char newline-char)
- (tty-flush-output)
(exit))
\f
;;;; GC, Interrupts, Errors
(define (fasload filename purify?)
(tty-write-char newline-char)
(tty-write-string filename)
- (tty-flush-output)
(let ((value (binary-fasload filename)))
(tty-write-string " loaded")
- (tty-flush-output)
(if purify?
(set! fasload-purification-queue
(cons (cons filename value)
(define (eval object environment)
(let ((value (scode-eval object environment)))
(tty-write-string " evaluated")
- (tty-flush-output)
value))
(define (package-initialize package-name procedure-name)
(tty-write-string " [")
(tty-write-string (system-pair-car procedure-name))
(tty-write-string "]")))
- (tty-flush-output)
((lexical-reference (package-reference package-name) procedure-name)))
(define (package-reference name)
;; I/O
(RUNTIME CONSOLE-INPUT)
(RUNTIME CONSOLE-OUTPUT)
+ (RUNTIME TRANSCRIPT)
(RUNTIME FILE-INPUT)
(RUNTIME FILE-OUTPUT)
(RUNTIME STRING-INPUT)
(RUNTIME TRUNCATED-STRING-OUTPUT)
(RUNTIME INPUT-PORT)
(RUNTIME OUTPUT-PORT)
- (RUNTIME SUBPROCESSES)
- (RUNTIME SUBPROCESSES INPUT)
- (RUNTIME SUBPROCESSES OUTPUT)
(RUNTIME WORKING-DIRECTORY)
(RUNTIME DIRECTORY)
(RUNTIME LOAD)
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.66 1990/04/21 16:26:47 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.67 1990/06/20 20:29:56 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(export ()
console-input-port)
(export (runtime emacs-interface)
- hook/read-char-immediate
hook/read-finish
hook/read-start)
(initialization (initialize-package!)))
open-output-file)
(initialization (initialize-package!)))
+(define-package (runtime transcript)
+ (files "tscript")
+ (parent ())
+ (export ()
+ transcript-off
+ transcript-on)
+ (export (runtime console-input)
+ transcript-port)
+ (export (runtime console-output)
+ transcript-port)
+ (initialization (initialize-package!)))
+
(define-package (runtime format)
(file-case options
((load) "format")
input-port/discard-char
input-port/discard-chars
input-port/operation
+ input-port/operation-names
input-port/operation/char-ready?
input-port/operation/discard-char
input-port/operation/discard-chars
input-port/operation/peek-char
- input-port/operation/peek-char-immediate
input-port/operation/read-char
- input-port/operation/read-char-immediate
- input-port/operation/read-finish!
- input-port/operation/read-start!
input-port/operation/read-string
+ input-port/immediate-mode
+ input-port/normal-mode
input-port/peek-char
- input-port/peek-char-immediate
input-port/read-char
- input-port/read-char-immediate
- input-port/read-finish!
- input-port/read-start!
input-port/read-string
input-port/state
input-port?
error-type:file
error-type:illegal-argument
error-type:open-file
+ error-type:premature-write-termination
error-type:random-internal
error-type:wrong-type-argument
microcode-error-type)
output-port/custom-operation
output-port/flush-output
output-port/operation
+ output-port/operation-names
output-port/operation/flush-output
output-port/operation/write-char
output-port/operation/write-string
(export (runtime macros)
lambda-optional-tag)
(export (runtime unsyntaxer)
- lambda-optional-tag)
+ lambda-optional-tag
+ lambda-rest-tag)
(export (runtime parser-table)
collect-list-wrapper)
(initialization (initialize-package!)))
(export ()
->pathname
canonicalize-input-filename
+ canonicalize-input-pathname
canonicalize-output-filename
+ canonicalize-output-pathname
+ canonicalize-overwrite-filename
+ canonicalize-overwrite-pathname
file-exists?
init-file-truename
make-pathname
(files "io")
(parent ())
(export ()
- close-all-open-files)
+ close-all-open-files
+ copy-file)
(export (runtime file-input)
- channel-name
- close-physical-channel
- open-input-channel)
+ file-length
+ file-open-input-channel
+ input-buffer/channel
+ input-buffer/char-ready?
+ input-buffer/chars-remaining
+ input-buffer/close
+ input-buffer/discard-char
+ input-buffer/discard-until-delimiter
+ input-buffer/peek-char
+ input-buffer/read-char
+ input-buffer/read-substring
+ input-buffer/read-until-delimiter
+ make-input-buffer)
(export (runtime file-output)
- channel-name
- close-physical-channel
- open-append-channel
- open-output-channel)
- (export (runtime subprocesses input)
- close-physical-channel
- open-input-channel)
- (export (runtime subprocesses output)
- close-physical-channel
- open-output-channel)
+ channel-close
+ channel-write-char-block
+ channel-write-string-block
+ file-open-append-channel
+ file-open-output-channel
+ make-output-buffer
+ output-buffer/close
+ output-buffer/drain-block
+ output-buffer/set-size
+ output-buffer/size
+ output-buffer/write-char-block
+ output-buffer/write-string-block)
+ (export (runtime console-output)
+ channel-write-char-block
+ channel-write-string-block
+ make-output-buffer
+ output-buffer/drain-block
+ output-buffer/set-size
+ output-buffer/size
+ output-buffer/write-char-block
+ output-buffer/write-string-block
+ tty-output-channel)
+ (export (runtime console-input)
+ channel-type=terminal?
+ input-buffer/char-ready?
+ input-buffer/read-char
+ make-input-buffer
+ terminal-buffered
+ terminal-buffered?
+ terminal-char-ready?
+ terminal-nonbuffered
+ terminal-read-char
+ tty-input-channel)
(initialization (initialize-package!)))
(define-package (runtime random-number)
make-unassigned?
sequence-actions
sequence-components
+ sequence-immediate-actions
sequence?
unassigned?-components
unassigned?-name
working-directory-pathname)
(export (runtime emacs-interface)
hook/set-working-directory-pathname!)
- (initialization (initialize-package!)))
-
-(define-package (runtime subprocesses)
- (files "process")
- (parent ())
- (export ()
- create-process
- delete-process
- kill-process
- process?
- process/command-string
- process/microcode-process
- process/to-port
- process/from-port
- process-get-pid
- process-get-input-channel
- process-get-output-channel
- process-get-status-flags
- prim-process-char-ready?)
- (initialization (initialize-package!)))
-
-(define-package (runtime subprocesses input)
- (files "procin")
- (parent ())
- (export ()
- open-process-input)
- (initialization (initialize-package!)))
-
-(define-package (runtime subprocesses output)
- (files "procout")
- (parent ())
- (export ()
- open-process-output)
(initialization (initialize-package!)))
\ No newline at end of file
#| -*-Scheme-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.16 1990/04/21 16:25:12 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/uenvir.scm,v 14.17 1990/06/20 20:30:24 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
(dbg-block/find-name block name)))))
(define (assign-dbg-variable! block name get-value value)
- (let ((index (dbg-block/find-name block name))
- (variable (vector-ref (dbg-block/layout-vector block) index)))
+ (let* ((index (dbg-block/find-name block name))
+ (variable (vector-ref (dbg-block/layout-vector block) index)))
(case (dbg-variable/type variable)
((CELL)
(let ((cell (get-value index)))
projects / mit-scheme.git / commitdiff