From 7bc7a47c1e71c7c427cad450e8f7f5ac8feabc71 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 20 Jun 1990 20:30:31 +0000 Subject: [PATCH] * Changes to operating system interface to match those introduced in microcode version 11.33, which is required for this runtime system version. * The low-level channel abstraction has been changed -- it now contains only a microcode channel descriptor and the channel type. The microcode no longer knows the format of channels. * Subprocess support has been temporarily removed. New subprocess support is being designed to accompany changes in the microcode. * The file-copy primitive is now written in Scheme using lower-level file system and I/O operations. * Use `input-port/immediate-mode' and `input-port/normal-mode' to switch terminal mode. The operations `read-char-immediate' and `peek-char-immediate' are now obsolete. REP loops force the input port into normal mode, while the debugger forces it into immediate mode. * I/O buffering for input files, output files, and the console output is now done in Scheme. The microcode provides no buffering. These ports understand `buffer-size' and `set-buffer-size' operations to control the amount of buffering. A buffer size of 0 disables buffering entirely. * `read-start!' and `read-finish!' are now optional operations on input ports. * An input or output port will now report the set of operations that it responds to. --- v7/src/runtime/dbgcmd.scm | 20 +- v7/src/runtime/emacs.scm | 33 +- v7/src/runtime/input.scm | 109 +++--- v7/src/runtime/io.scm | 686 ++++++++++++++++++++++++++++++------- v7/src/runtime/load.scm | 8 +- v7/src/runtime/make.scm | 41 ++- v7/src/runtime/output.scm | 11 +- v7/src/runtime/pathnm.scm | 40 ++- v7/src/runtime/rep.scm | 75 ++-- v7/src/runtime/runtime.pkg | 131 +++---- v7/src/runtime/sfile.scm | 21 +- v7/src/runtime/uenvir.scm | 6 +- v7/src/runtime/uerror.scm | 8 +- v8/src/runtime/load.scm | 8 +- v8/src/runtime/make.scm | 41 ++- v8/src/runtime/runtime.pkg | 131 +++---- v8/src/runtime/uenvir.scm | 6 +- 17 files changed, 919 insertions(+), 456 deletions(-) diff --git a/v7/src/runtime/dbgcmd.scm b/v7/src/runtime/dbgcmd.scm index 2013f7838..7ed546f11 100644 --- a/v7/src/runtime/dbgcmd.scm +++ b/v7/src/runtime/dbgcmd.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -64,9 +64,17 @@ MIT in each case. |# (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)) @@ -111,7 +119,7 @@ MIT in each case. |# (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 diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm index 2daf7686b..3948af54e 100644 --- a/v7/src/runtime/emacs.scm +++ b/v7/src/runtime/emacs.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -37,11 +37,6 @@ MIT in each case. |# (declare (usual-integrations)) -(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)) @@ -138,12 +133,6 @@ MIT in each case. |# (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 @@ -173,10 +162,14 @@ MIT in each case. |# (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)) @@ -191,7 +184,6 @@ MIT in each case. |# (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) @@ -209,7 +201,6 @@ MIT in each case. |# (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) @@ -224,7 +215,7 @@ MIT in each case. |# (install!)) (define (install!) - ((if (under-emacs?) + ((if ((ucode-primitive under-emacs? 0)) install-emacs-hooks! install-normal-hooks!))) @@ -235,7 +226,6 @@ MIT in each case. |# (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) @@ -255,7 +245,6 @@ MIT in each case. |# (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) diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm index d729f55f6..e48f26a00 100644 --- a/v7/src/runtime/input.scm +++ b/v7/src/runtime/input.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -56,14 +56,11 @@ MIT in each case. |# (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)) @@ -80,20 +77,16 @@ MIT in each case. |# (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)))) (define (make-input-port operations state) @@ -105,36 +98,34 @@ MIT in each case. |# (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 @@ -153,14 +144,6 @@ MIT in each case. |# (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) (define (input-port/char-ready? port interval) ((input-port/operation/char-ready? port) port interval)) @@ -171,12 +154,6 @@ MIT in each case. |# (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)) @@ -186,11 +163,17 @@ MIT in each case. |# (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") @@ -261,7 +244,7 @@ MIT in each case. |# (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) @@ -269,7 +252,7 @@ MIT in each case. |# (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) @@ -278,7 +261,7 @@ MIT in each case. |# (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) @@ -298,9 +281,13 @@ MIT in each case. |# (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) diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index a8ac79277..b8ba7b9a9 100644 --- a/v7/src/runtime/io.scm +++ b/v7/src/runtime/io.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -32,156 +32,112 @@ Technology nor of any adaptation thereof in any advertising, 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)) +(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))) -;;;; 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)) - -;;; 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))))))))))) - -;;;; 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!) - + +(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 @@ -191,16 +147,482 @@ MIT in each case. |# #| (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))) + +;;;; 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))))))) + +(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)) + +;;;; 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)))))) + +;;;; 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)))) + +;;;; 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))))) + +(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))))) + +(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 diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index 8a1c9a089..f281857e0 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -198,8 +198,7 @@ MIT in each case. |# (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))) @@ -221,7 +220,8 @@ MIT in each case. |# (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) diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index 39b73cdd2..7f1b97a79 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -42,8 +42,11 @@ MIT in each case. |# (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) @@ -63,27 +66,33 @@ MIT in each case. |# 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)) ;;;; GC, Interrupts, Errors @@ -123,10 +132,8 @@ MIT in each case. |# (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) @@ -136,7 +143,6 @@ MIT in each case. |# (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) @@ -155,7 +161,6 @@ MIT in each case. |# (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) @@ -309,6 +314,7 @@ MIT in each case. |# ;; I/O (RUNTIME CONSOLE-INPUT) (RUNTIME CONSOLE-OUTPUT) + (RUNTIME TRANSCRIPT) (RUNTIME FILE-INPUT) (RUNTIME FILE-OUTPUT) (RUNTIME STRING-INPUT) @@ -316,9 +322,6 @@ MIT in each case. |# (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) diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm index 985845b2c..ea43542ea 100644 --- a/v7/src/runtime/output.scm +++ b/v7/src/runtime/output.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -57,7 +57,8 @@ MIT in each case. |# (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)) @@ -99,7 +100,9 @@ MIT in each case. |# (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)) diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm index bdba0dbd0..76d05c967 100644 --- a/v7/src/runtime/pathnm.scm +++ b/v7/src/runtime/pathnm.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -334,6 +334,15 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|# ;;;; 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? @@ -347,6 +356,12 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|# (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)) @@ -361,14 +376,21 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|# 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))) diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index 0b97c207b..63679bbaa 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -263,20 +263,22 @@ MIT in each case. |# (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)) @@ -562,29 +564,34 @@ MIT in each case. |# (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 () diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 76eb17840..ae1958354 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -265,7 +265,6 @@ MIT in each case. |# (export () console-input-port) (export (runtime emacs-interface) - hook/read-char-immediate hook/read-finish hook/read-start) (initialization (initialize-package!))) @@ -548,6 +547,18 @@ MIT in each case. |# 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") @@ -712,22 +723,17 @@ MIT in each case. |# 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? @@ -938,6 +944,7 @@ MIT in each case. |# 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) @@ -1109,6 +1116,7 @@ MIT in each case. |# 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 @@ -1145,7 +1153,8 @@ MIT in each case. |# (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!))) @@ -1176,7 +1185,11 @@ MIT in each case. |# (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 @@ -1265,22 +1278,56 @@ MIT in each case. |# (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) @@ -1531,6 +1578,7 @@ MIT in each case. |# make-unassigned? sequence-actions sequence-components + sequence-immediate-actions sequence? unassigned?-components unassigned?-name @@ -1879,37 +1927,4 @@ MIT in each case. |# 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 diff --git a/v7/src/runtime/sfile.scm b/v7/src/runtime/sfile.scm index f50495b44..3e42a2835 100644 --- a/v7/src/runtime/sfile.scm +++ b/v7/src/runtime/sfile.scm @@ -1,8 +1,8 @@ #| -*-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 @@ -36,10 +36,6 @@ MIT in each case. |# ;;; package: () (declare (usual-integrations)) - -(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) @@ -50,15 +46,4 @@ MIT in each case. |# (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 diff --git a/v7/src/runtime/uenvir.scm b/v7/src/runtime/uenvir.scm index 921e68b5a..ac0498983 100644 --- a/v7/src/runtime/uenvir.scm +++ b/v7/src/runtime/uenvir.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -575,8 +575,8 @@ MIT in each case. |# (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))) diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm index cdff0326f..13d5f1bea 100644 --- a/v7/src/runtime/uerror.scm +++ b/v7/src/runtime/uerror.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -208,9 +208,10 @@ MIT in each case. |# (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) @@ -235,6 +236,9 @@ MIT in each case. |# (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"))) diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm index 65d00a3f4..2f3d9bab4 100644 --- a/v8/src/runtime/load.scm +++ b/v8/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -198,8 +198,7 @@ MIT in each case. |# (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))) @@ -221,7 +220,8 @@ MIT in each case. |# (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) diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm index 410e9c445..fedb0d37b 100644 --- a/v8/src/runtime/make.scm +++ b/v8/src/runtime/make.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -42,8 +42,11 @@ MIT in each case. |# (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) @@ -63,27 +66,33 @@ MIT in each case. |# 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)) ;;;; GC, Interrupts, Errors @@ -123,10 +132,8 @@ MIT in each case. |# (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) @@ -136,7 +143,6 @@ MIT in each case. |# (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) @@ -155,7 +161,6 @@ MIT in each case. |# (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) @@ -309,6 +314,7 @@ MIT in each case. |# ;; I/O (RUNTIME CONSOLE-INPUT) (RUNTIME CONSOLE-OUTPUT) + (RUNTIME TRANSCRIPT) (RUNTIME FILE-INPUT) (RUNTIME FILE-OUTPUT) (RUNTIME STRING-INPUT) @@ -316,9 +322,6 @@ MIT in each case. |# (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) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index 3e1f712d1..a4dc7ab86 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-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 @@ -265,7 +265,6 @@ MIT in each case. |# (export () console-input-port) (export (runtime emacs-interface) - hook/read-char-immediate hook/read-finish hook/read-start) (initialization (initialize-package!))) @@ -548,6 +547,18 @@ MIT in each case. |# 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") @@ -712,22 +723,17 @@ MIT in each case. |# 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? @@ -938,6 +944,7 @@ MIT in each case. |# 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) @@ -1109,6 +1116,7 @@ MIT in each case. |# 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 @@ -1145,7 +1153,8 @@ MIT in each case. |# (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!))) @@ -1176,7 +1185,11 @@ MIT in each case. |# (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 @@ -1265,22 +1278,56 @@ MIT in each case. |# (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) @@ -1531,6 +1578,7 @@ MIT in each case. |# make-unassigned? sequence-actions sequence-components + sequence-immediate-actions sequence? unassigned?-components unassigned?-name @@ -1879,37 +1927,4 @@ MIT in each case. |# 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 diff --git a/v8/src/runtime/uenvir.scm b/v8/src/runtime/uenvir.scm index faeaee161..2574a618b 100644 --- a/v8/src/runtime/uenvir.scm +++ b/v8/src/runtime/uenvir.scm @@ -1,6 +1,6 @@ #| -*-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 @@ -575,8 +575,8 @@ MIT in each case. |# (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))) -- 2.25.1