From a268615e97c410c01d26c4a2fcdf5c864e809e85 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 21 Oct 1993 11:49:56 +0000 Subject: [PATCH] * Define new standard ports to replace nearly all instances of NEAREST-CMDL/PORT. When a CMDL starts, it binds all of these ports to the CMDL port; but they can each be rebound separately without affecting the CMDL port. (ERROR-OUTPUT-PORT) errors and warnings (NOTIFICATION-OUTPUT-PORT) load messages, etc. (TRACE-OUTPUT-PORT) output from TRACE (INTERACTION-I/O-PORT) prompting * Implement IGNORE-ERRORS procedure. Change WRITE-CONDITION-REPORT so that it ignores errors that occur while writing the report, but only if the condition being reported is an error condition. * Implement GUARANTEE-I/O-PORT. --- v7/src/runtime/advice.scm | 45 +++++++-------- v7/src/runtime/error.scm | 18 +++++- v7/src/runtime/fileio.scm | 115 ++++++++++++++++++++++++------------- v7/src/runtime/gcnote.scm | 21 +++---- v7/src/runtime/global.scm | 17 ++---- v7/src/runtime/input.scm | 47 +-------------- v7/src/runtime/load.scm | 6 +- v7/src/runtime/output.scm | 47 +-------------- v7/src/runtime/packag.scm | 4 +- v7/src/runtime/port.scm | 108 +++++++++++++++++++++++++++++++--- v7/src/runtime/rep.scm | 33 +++++------ v7/src/runtime/runtime.pkg | 92 ++++++++++++++++------------- v7/src/runtime/uerror.scm | 6 +- v7/src/runtime/usrint.scm | 22 ++++--- v7/src/runtime/version.scm | 4 +- v8/src/runtime/global.scm | 17 ++---- v8/src/runtime/load.scm | 6 +- v8/src/runtime/runtime.pkg | 92 ++++++++++++++++------------- 18 files changed, 384 insertions(+), 316 deletions(-) diff --git a/v7/src/runtime/advice.scm b/v7/src/runtime/advice.scm index 9366b7581..1269e46a5 100644 --- a/v7/src/runtime/advice.scm +++ b/v7/src/runtime/advice.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: advice.scm,v 14.12 1993/10/15 10:26:28 cph Exp $ +$Id: advice.scm,v 14.13 1993/10/21 11:49:41 cph Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -360,54 +360,51 @@ MIT in each case. |# (define (trace-entry-advice procedure arguments environment) environment - (trace-display procedure arguments)) + (trace-display (trace-output-port) procedure arguments)) (define (trace-exit-advice procedure arguments result environment) environment - (trace-display procedure arguments result) + (trace-display (trace-output-port) procedure arguments result) result) -(define (trace-display procedure arguments #!optional result) - (newline) - (let ((width (-1+ (max 40 (output-port/x-size (current-output-port))))) +(define (trace-display port procedure arguments #!optional result) + (newline port) + (let ((width (- (max 40 (output-port/x-size port)) 1)) (write-truncated (lambda (object width) - (let ((output - (with-output-to-truncated-string width - (lambda () - (write object))))) + (let ((output (write-to-string object width))) (if (car output) (substring-fill! (cdr output) (- width 3) width #\.)) - (write-string (cdr output)))))) + (write-string (cdr output) port))))) (if (default-object? result) - (write-string "[Entering ") + (write-string "[Entering " port) (begin - (write-string "[") + (write-string "[" port) (write-truncated result (- width 2)) - (newline) - (write-string " <== "))) + (newline port) + (write-string " <== " port))) (write-truncated procedure (- width 11)) (if (null? arguments) - (write-string "]") + (write-string "]" port) (begin - (newline) + (newline port) (let ((write-args (lambda (arguments) (let loop ((prefix " Args: ") (arguments arguments)) - (write-string prefix) + (write-string prefix port) (write-truncated (car arguments) (- width 11)) (if (not (null? (cdr arguments))) (begin - (newline) + (newline port) (loop " " (cdr arguments)))))))) (if (<= (length arguments) 10) (begin (write-args arguments) - (write-string "]")) + (write-string "]" port)) (begin (write-args (list-head arguments 10)) - (newline) - (write-string " ...]")))))))) + (newline port) + (write-string " ...]" port)))))))) (define (break-entry-advice procedure arguments environment) (fluid-let ((the-procedure procedure) @@ -424,9 +421,7 @@ MIT in each case. |# (define (break-rep environment message . info) (breakpoint (cmdl-message/append (cmdl-message/active (lambda (port) - (with-output-to-port port - (lambda () - (apply trace-display info))))) + (apply trace-display port info))) message) environment advice-continuation)) diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index 8c3b56c40..a2ee89f7e 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: error.scm,v 14.35 1993/10/15 10:26:30 cph Exp $ +$Id: error.scm,v 14.36 1993/10/21 11:49:42 cph Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -272,7 +272,10 @@ MIT in each case. |# (define (write-condition-report condition port) (guarantee-condition condition 'WRITE-CONDITION-REPORT) (guarantee-output-port port 'WRITE-CONDITION-REPORT) - ((%condition-type/reporter (%condition/type condition)) condition port)) + (let ((reporter (%condition-type/reporter (%condition/type condition)))) + (if (%condition/error? condition) + (ignore-errors (lambda () (reporter condition port))) + (reporter condition port)))) (define (condition/report-string condition) (with-string-output-port @@ -446,6 +449,12 @@ MIT in each case. |# (cons (cons types handler) dynamic-handler-frames))) (thunk))) +(define (ignore-errors thunk) + (call-with-current-continuation + (lambda (continuation) + (bind-condition-handler (list condition-type:error) continuation + thunk)))) + (define (break-on-signals types) (guarantee-condition-types types 'BREAK-ON-SIGNALS) (set! break-on-signals-types types) @@ -535,7 +544,7 @@ MIT in each case. |# (if hook (fluid-let ((standard-warning-hook false)) (hook condition)) - (let ((port (nearest-cmdl/port))) + (let ((port (error-output-port))) (fresh-line port) (write-string ";Warning: " port) (write-condition-report condition port))))) @@ -664,6 +673,9 @@ MIT in each case. |# (define (condition/error? condition) (guarantee-condition condition 'CONDITION/ERROR?) + (%condition/error? condition)) + +(define-integrable (%condition/error? condition) (%condition-type/error? (%condition/type condition))) (define-integrable (%condition-type/error? type) diff --git a/v7/src/runtime/fileio.scm b/v7/src/runtime/fileio.scm index ac005509e..54761b652 100644 --- a/v7/src/runtime/fileio.scm +++ b/v7/src/runtime/fileio.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: fileio.scm,v 1.5 1993/01/12 23:08:51 gjr Exp $ +$Id: fileio.scm,v 1.6 1993/10/21 11:49:43 cph Exp $ Copyright (c) 1991-1993 Massachusetts Institute of Technology @@ -95,21 +95,23 @@ MIT in each case. |# (define input-file-template) (define output-file-template) (define i/o-file-template) + +(define input-buffer-size 512) +(define output-buffer-size 512) (define (open-input-file filename) (let* ((pathname (merge-pathnames filename)) (channel (file-open-input-channel (->namestring pathname))) (port - (port/copy input-file-template - (make-file-state - (make-input-buffer channel - input-buffer-size - (pathname-newline-translation - pathname) - (pathname-end-of-file-marker/input - pathname)) - false - pathname)))) + (port/copy + input-file-template + (make-file-state + (make-input-buffer channel + input-buffer-size + (pathname-newline-translation pathname) + (pathname-end-of-file-marker/input pathname)) + false + pathname)))) (set-channel-port! channel port) port)) @@ -121,39 +123,35 @@ MIT in each case. |# (file-open-append-channel filename) (file-open-output-channel filename)))) (port - (port/copy output-file-template - (make-file-state - false - (make-output-buffer channel - output-buffer-size - (pathname-newline-translation - pathname) - (pathname-end-of-file-marker/output - pathname)) - pathname)))) + (port/copy + output-file-template + (make-file-state + false + (make-output-buffer channel + output-buffer-size + (pathname-newline-translation pathname) + (pathname-end-of-file-marker/output pathname)) + pathname)))) (set-channel-port! channel port) port)) (define (open-i/o-file filename) (let* ((pathname (merge-pathnames filename)) (channel (file-open-io-channel (->namestring pathname))) + (translation (pathname-newline-translation pathname)) (port - (let ((translation (pathname-newline-translation pathname))) - (port/copy i/o-file-template - (make-file-state - (make-input-buffer - channel - input-buffer-size - translation - (pathname-end-of-file-marker/input - pathname)) - (make-output-buffer - channel - output-buffer-size - translation - (pathname-end-of-file-marker/output - pathname)) - pathname))))) + (port/copy + i/o-file-template + (make-file-state + (make-input-buffer channel + input-buffer-size + translation + (pathname-end-of-file-marker/input pathname)) + (make-output-buffer channel + output-buffer-size + translation + (pathname-end-of-file-marker/output pathname)) + pathname)))) (set-channel-port! channel port) port)) @@ -162,9 +160,6 @@ MIT in each case. |# (and (not (string=? "\n" end-of-line)) end-of-line))) -(define input-buffer-size 512) -(define output-buffer-size 512) - (define (open-binary-input-file filename) (let* ((pathname (merge-pathnames filename)) (channel (file-open-input-channel (->namestring pathname))) @@ -214,6 +209,46 @@ MIT in each case. |# (set-channel-port! channel port) port)) +(define ((make-call-with-file open) input-specifier receiver) + (let ((port (open input-specifier))) + (let ((value (receiver port))) + (close-port port) + value))) + +(define call-with-input-file + (make-call-with-file open-input-file)) + +(define call-with-binary-input-file + (make-call-with-file open-binary-input-file)) + +(define call-with-output-file + (make-call-with-file open-output-file)) + +(define call-with-binary-output-file + (make-call-with-file open-binary-output-file)) + +(define ((make-with-input-from-file call) input-specifier thunk) + (call input-specifier + (lambda (port) + (with-input-from-port port thunk)))) + +(define with-input-from-file + (make-with-input-from-file call-with-input-file)) + +(define with-input-from-binary-file + (make-with-input-from-file call-with-binary-input-file)) + +(define ((make-with-output-to-file call) output-specifier thunk) + (call output-specifier + (lambda (port) + (with-output-to-port port thunk)))) + +(define with-output-to-file + (make-with-output-to-file call-with-output-file)) + +(define with-output-to-binary-file + (make-with-output-to-file call-with-binary-output-file)) + (define-structure (file-state (type vector) (conc-name file-state/)) ;; First two elements of this vector are required by the generic diff --git a/v7/src/runtime/gcnote.scm b/v7/src/runtime/gcnote.scm index b7c01af06..667f47f2d 100644 --- a/v7/src/runtime/gcnote.scm +++ b/v7/src/runtime/gcnote.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gcnote.scm,v 14.9 1991/11/26 06:43:48 cph Exp $ +$Id: gcnote.scm,v 14.10 1993/10/21 11:49:44 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -51,9 +51,7 @@ MIT in each case. |# (thunk))) (define (gc-notification statistic) - (with-output-to-port (nearest-cmdl/port) - (lambda () - (print-statistic statistic)))) + (print-statistic statistic (notification-output-port))) (define (print-gc-statistics) (let ((status ((ucode-primitive gc-space-status)))) @@ -87,11 +85,14 @@ MIT in each case. |# (vector-ref status 4) (vector-ref status 5) (vector-ref status 6)))))) - (for-each print-statistic (gc-statistics))) - -(define (print-statistic statistic) - (newline) - (write-string (gc-statistic->string statistic))) + (for-each (let ((port (current-output-port))) + (lambda (statistic) + (print-statistic statistic port))) + (gc-statistics))) + +(define (print-statistic statistic port) + (newline port) + (write-string (gc-statistic->string statistic) port)) (define (gc-statistic->string statistic) (let* ((ticks/second 1000) diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm index f0e7db1b0..8802b6458 100644 --- a/v7/src/runtime/global.scm +++ b/v7/src/runtime/global.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: global.scm,v 14.45 1992/12/22 20:59:33 cph Exp $ +$Id: global.scm,v 14.46 1993/10/21 11:49:45 cph Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -144,14 +144,9 @@ MIT in each case. |# (define with-values call-with-values) (define (write-to-string object #!optional max) - (if (default-object? max) (set! max false)) - (if (not max) - (with-output-to-string - (lambda () - (write object))) - (with-output-to-truncated-string max - (lambda () - (write object))))) + (if (or (default-object? max) (not max)) + (with-output-to-string (lambda () (write object))) + (with-output-to-truncated-string max (lambda () (write object))))) (define (pa procedure) (if (not (procedure? procedure)) @@ -266,7 +261,7 @@ MIT in each case. |# (no-print (lambda () unspecific))) (if (or (default-object? suppress-messages?) (not suppress-messages?)) - (let ((port (nearest-cmdl/port))) + (let ((port (notification-output-port))) (do-it (lambda () (fresh-line port) (write-string ";Dumping " port) diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm index 0844b807d..086a16313 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.15 1992/05/26 23:08:41 mhwu Exp $ +$Id: input.scm,v 14.16 1993/10/21 11:49:45 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -39,11 +39,6 @@ MIT in each case. |# ;;;; Input Ports -(define (guarantee-input-port port) - (if (not (input-port? port)) - (error:wrong-type-argument port "input port" false)) - port) - (define (input-port/char-ready? port interval) ((input-port/operation/char-ready? port) port interval)) @@ -71,44 +66,6 @@ MIT in each case. |# (define (make-eof-object port) port eof-object) - -(define *current-input-port*) - -(define-integrable (current-input-port) - *current-input-port*) - -(define (set-current-input-port! port) - (guarantee-input-port port) - (set! *current-input-port* port) - unspecific) - -(define (with-input-from-port port thunk) - (guarantee-input-port port) - (fluid-let ((*current-input-port* port)) (thunk))) - -(define ((make-call-with-input-file open) input-specifier receiver) - (let ((port (open input-specifier))) - (let ((value (receiver port))) - (close-port port) - value))) - -(define call-with-input-file - (make-call-with-input-file open-input-file)) - -(define call-with-binary-input-file - (make-call-with-input-file open-binary-input-file)) - -(define ((make-with-input-from-file call) input-specifier thunk) - (call input-specifier - (lambda (port) - (fluid-let ((*current-input-port* port)) - (thunk))))) - -(define with-input-from-file - (make-with-input-from-file call-with-input-file)) - -(define with-input-from-binary-file - (make-with-input-from-file call-with-binary-input-file)) ;;;; Input Procedures diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index f7809e80a..756dfdf7b 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: load.scm,v 14.44 1993/10/15 10:26:32 cph Exp $ +$Id: load.scm,v 14.45 1993/10/21 11:49:46 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -101,7 +101,7 @@ MIT in each case. |# (define (loading-message suppress-loading-message? pathname do-it) (if suppress-loading-message? (do-it) - (let ((port (nearest-cmdl/port))) + (let ((port (notification-output-port))) (fresh-line port) (write-string ";Loading " port) (write (enough-namestring pathname) port) @@ -478,7 +478,7 @@ MIT in each case. |# (define (loading-message fname suppress? kind) (if (not suppress?) - (let ((port (nearest-cmdl/port))) + (let ((port (notification-output-port))) (fresh-line port) (write-string kind port) (write-string (->namestring (->pathname fname))) diff --git a/v7/src/runtime/output.scm b/v7/src/runtime/output.scm index 68f65f755..14e8661bc 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.14 1992/05/26 23:12:19 mhwu Exp $ +$Id: output.scm,v 14.15 1993/10/21 11:49:47 cph Exp $ -Copyright (c) 1988-91 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -39,11 +39,6 @@ MIT in each case. |# ;;;; Output Ports -(define (guarantee-output-port port) - (if (not (output-port? port)) - (error:wrong-type-argument port "output port" false)) - port) - (define (output-port/write-char port char) ((output-port/operation/write-char port) port char)) @@ -72,44 +67,6 @@ MIT in each case. |# (let ((operation (port/operation port 'Y-SIZE))) (and operation (operation port)))) - -(define *current-output-port*) - -(define-integrable (current-output-port) - *current-output-port*) - -(define (set-current-output-port! port) - (guarantee-output-port port) - (set! *current-output-port* port) - unspecific) - -(define (with-output-to-port port thunk) - (guarantee-output-port port) - (fluid-let ((*current-output-port* port)) (thunk))) - -(define ((make-call-with-output-file open) output-specifier receiver) - (let ((port (open output-specifier))) - (let ((value (receiver port))) - (close-port port) - value))) - -(define call-with-output-file - (make-call-with-output-file open-output-file)) - -(define call-with-binary-output-file - (make-call-with-output-file open-binary-output-file)) - -(define ((make-with-output-to-file call) output-specifier thunk) - (call output-specifier - (lambda (port) - (fluid-let ((*current-output-port* port)) - (thunk))))) - -(define with-output-to-file - (make-with-output-to-file call-with-output-file)) - -(define with-output-to-binary-file - (make-with-output-to-file call-with-binary-output-file)) ;;;; Output Procedures diff --git a/v7/src/runtime/packag.scm b/v7/src/runtime/packag.scm index 737e5ee38..9ff8e2a8b 100644 --- a/v7/src/runtime/packag.scm +++ b/v7/src/runtime/packag.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: packag.scm,v 14.16 1993/06/25 23:14:58 gjr Exp $ +$Id: packag.scm,v 14.17 1993/10/21 11:49:48 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -194,7 +194,7 @@ MIT in each case. |# (if (or (not value) load/suppress-loading-message?) value - (let ((port (nearest-cmdl/port))) + (let ((port (notification-output-port))) (fresh-line port) (write-string ";Initialized " port) (write name port) diff --git a/v7/src/runtime/port.scm b/v7/src/runtime/port.scm index af28393a0..cbaf35198 100644 --- a/v7/src/runtime/port.scm +++ b/v7/src/runtime/port.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/port.scm,v 1.4 1992/02/27 01:11:19 cph Exp $ +$Id: port.scm,v 1.5 1993/10/21 11:49:49 cph Exp $ -Copyright (c) 1991-92 Massachusetts Institute of Technology +Copyright (c) 1991-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -167,7 +167,7 @@ MIT in each case. |# (define output-port/operation-names port/operation-names) (define output-port/state port/state) (define set-output-port/state! set-port/state!) - + (define (input-port/operation port name) (port/operation port (case name @@ -188,24 +188,39 @@ MIT in each case. |# (define input-port/custom-operation input-port/operation) (define output-port/custom-operation output-port/operation) - -;;;; Constructors (define (input-port? object) (and (port? object) (input-port/operation/read-char object) - true)) + #t)) (define (output-port? object) (and (port? object) (output-port/operation/write-char object) - true)) + #t)) (define (i/o-port? object) (and (port? object) (input-port/operation/read-char object) (output-port/operation/write-char object) - true)) + #t)) + +(define (guarantee-input-port port) + (if (not (input-port? port)) + (error:wrong-type-argument port "input port" #f)) + port) + +(define (guarantee-output-port port) + (if (not (output-port? port)) + (error:wrong-type-argument port "output port" #f)) + port) + +(define (guarantee-i/o-port port) + (if (not (i/o-port? port)) + (error:wrong-type-argument port "I/O port" #f)) + port) + +;;;; Constructors (define (make-input-port operations state) (make-port operations state 'MAKE-INPUT-PORT true false)) @@ -467,4 +482,79 @@ MIT in each case. |# (lambda () (set! mode (read-mode port)) (write-mode port outside-mode)))) - (thunk)))) \ No newline at end of file + (thunk)))) + +;;;; Standard Ports + +(define *current-input-port*) +(define *current-output-port*) +(define *error-output-port* #f) +(define *notification-output-port* #f) +(define *trace-output-port* #f) +(define *interaction-i/o-port* #f) + +(define (current-input-port) + *current-input-port*) + +(define (set-current-input-port! port) + (set! *current-input-port* (guarantee-input-port port)) + unspecific) + +(define (with-input-from-port port thunk) + (fluid-let ((*current-input-port* (guarantee-input-port port))) + (thunk))) + +(define (current-output-port) + *current-output-port*) + +(define (set-current-output-port! port) + (set! *current-output-port* (guarantee-output-port port)) + unspecific) + +(define (with-output-to-port port thunk) + (fluid-let ((*current-output-port* (guarantee-output-port port))) + (thunk))) + +(define (error-output-port) + (or *error-output-port* (nearest-cmdl/port))) + +(define (set-error-output-port! port) + (set! *error-output-port* (guarantee-output-port port)) + unspecific) + +(define (with-error-output-port port thunk) + (fluid-let ((*error-output-port* (guarantee-output-port port))) + (thunk))) + +(define (notification-output-port) + (or *notification-output-port* (nearest-cmdl/port))) + +(define (set-notification-output-port! port) + (set! *notification-output-port* (guarantee-output-port port)) + unspecific) + +(define (with-notification-output-port port thunk) + (fluid-let ((*notification-output-port* (guarantee-output-port port))) + (thunk))) + +(define (trace-output-port) + (or *trace-output-port* (nearest-cmdl/port))) + +(define (set-trace-output-port! port) + (set! *trace-output-port* (guarantee-output-port port)) + unspecific) + +(define (with-trace-output-port port thunk) + (fluid-let ((*trace-output-port* (guarantee-output-port port))) + (thunk))) + +(define (interaction-i/o-port) + (or *interaction-i/o-port* (nearest-cmdl/port))) + +(define (set-interaction-i/o-port! port) + (set! *interaction-i/o-port* (guarantee-i/o-port port)) + unspecific) + +(define (with-interaction-i/o-port port thunk) + (fluid-let ((*interaction-i/o-port* (guarantee-i/o-port port))) + (thunk))) \ No newline at end of file diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index f57e5486f..eddca4fb6 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: rep.scm,v 14.39 1993/10/21 04:52:42 cph Exp $ +$Id: rep.scm,v 14.40 1993/10/21 11:49:51 cph Exp $ Copyright (c) 1988-93 Massachusetts Institute of Technology @@ -142,7 +142,11 @@ MIT in each case. |# (*default-pathname-defaults* *default-pathname-defaults*) (*current-input-port* port) - (*current-output-port* port)) + (*current-output-port* port) + (*error-output-port* port) + (*notification-output-port* port) + (*trace-output-port* port) + (*interaction-output-port* port)) (let loop ((message message)) (loop (bind-abort-restart cmdl @@ -151,7 +155,7 @@ MIT in each case. |# (lambda (interrupt-mask) interrupt-mask (unblock-thread-events) - (with-errors-ignored + (ignore-errors (lambda () ((->cmdl-message message) cmdl))) (call-with-current-continuation @@ -180,12 +184,6 @@ MIT in each case. |# => (lambda (operation) (operation cmdl thunk))) (else (with-thread-mutex-locked mutex thunk))))))) - -(define (with-errors-ignored thunk) - (call-with-current-continuation - (lambda (continuation) - (bind-condition-handler (list condition-type:error) continuation - thunk)))) (define (bind-abort-restart cmdl thunk) (call-with-current-continuation @@ -477,11 +475,14 @@ MIT in each case. |# (cmdl-message/append (or message (and condition - (cmdl-message/strings - (fluid-let ((*unparser-list-depth-limit* 25) - (*unparser-list-breadth-limit* 100) - (*unparser-string-length-limit* 500)) - (condition/report-string condition))))) + (cmdl-message/active + (let ((port (error-output-port))) + (lambda (ignore) + ignore + (fluid-let ((*unparser-list-depth-limit* 25) + (*unparser-list-breadth-limit* 100) + (*unparser-string-length-limit* 500)) + (write-condition-report condition port))))))) (and condition (cmdl-message/append (and (condition/error? condition) @@ -554,7 +555,7 @@ MIT in each case. |# restarts (- n-restarts (if (default-object? n) - (let ((port (nearest-cmdl/port))) + (let ((port (interaction-i/o-port))) (fresh-line port) (write-string ";Choose an option by number:" port) (write-restarts restarts port @@ -787,7 +788,7 @@ MIT in each case. |# (if (default-object? value) (continue) (use-value value)) - (let ((port (nearest-cmdl/port))) + (let ((port (error-output-port))) (fresh-line port) (write-string ";Unable to PROCEED" port))) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index acc6f112b..8595331b3 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.206 1993/10/21 04:52:50 cph Exp $ +$Id: runtime.pkg,v 14.207 1993/10/21 11:49:53 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -231,8 +231,7 @@ MIT in each case. |# compiled-procedure/lambda discard-debugging-info! load-debugging-info-on-demand? - uncompress-ports - ) + uncompress-ports) (export (runtime load) dbg-info-vector/purification-root dbg-info-vector? @@ -274,11 +273,9 @@ MIT in each case. |# dbg-continuation/source-code dbg-procedure? dbg-procedure/source-code - dbg-expression? - ) + dbg-expression?) (export (runtime compress) - uncompress-internal - ) + uncompress-internal) (initialization (initialize-package!))) (define-package (runtime console-i/o-port) @@ -614,6 +611,7 @@ MIT in each case. |# find-restart format-error-message hook/invoke-condition-handler + ignore-errors invoke-restart invoke-restart-interactively make-condition @@ -667,12 +665,20 @@ MIT in each case. |# (files "fileio") (parent ()) (export () + call-with-binary-input-file + call-with-binary-output-file + call-with-input-file + call-with-output-file open-binary-i/o-file open-binary-input-file open-binary-output-file open-i/o-file open-input-file - open-output-file) + open-output-file + with-input-from-binary-file + with-input-from-file + with-output-to-binary-file + with-output-to-file) (initialization (initialize-package!))) (define-package (runtime transcript) @@ -941,6 +947,12 @@ MIT in each case. |# close-input-port close-output-port close-port + current-input-port + current-output-port + error-output-port + guarantee-i/o-port + guarantee-input-port + guarantee-output-port i/o-port? input-port/channel input-port/copy @@ -955,9 +967,11 @@ MIT in each case. |# input-port/operation/read-string input-port/state input-port? + interaction-i/o-port make-i/o-port make-input-port make-output-port + notification-output-port output-port/channel output-port/copy output-port/custom-operation @@ -990,9 +1004,29 @@ MIT in each case. |# port/with-output-blocking-mode port/with-output-terminal-mode port? + set-current-input-port! + set-current-output-port! + set-error-output-port! set-input-port/state! + set-interaction-i/o-port! + set-notification-output-port! set-output-port/state! - set-port/state!) + set-port/state! + set-trace-output-port! + trace-output-port + with-error-output-port + with-input-from-port + with-interaction-i/o-port + with-notification-output-port + with-output-to-port + with-trace-output-port) + (export (runtime rep) + *current-input-port* + *current-output-port* + *error-output-port* + *interaction-i/o-port* + *notification-output-port* + *trace-output-port*) (export (runtime emacs-interface) set-port/thread-mutex!)) @@ -1000,12 +1034,8 @@ MIT in each case. |# (files "input") (parent ()) (export () - call-with-input-file - call-with-binary-input-file char-ready? - current-input-port eof-object? - guarantee-input-port input-port/char-ready? input-port/discard-char input-port/discard-chars @@ -1017,13 +1047,7 @@ MIT in each case. |# read read-char read-char-no-hang - read-string - set-current-input-port! - with-input-from-file - with-input-from-binary-file - with-input-from-port) - (export (runtime rep) - *current-input-port*) + read-string) (export (runtime primitive-io) eof-object)) @@ -1032,14 +1056,10 @@ MIT in each case. |# (parent ()) (export () beep - call-with-output-file - call-with-binary-output-file clear - current-output-port display flush-output fresh-line - guarantee-output-port newline output-port/discretionary-flush output-port/flush-output @@ -1049,16 +1069,10 @@ MIT in each case. |# output-port/write-substring output-port/x-size output-port/y-size - set-current-output-port! - with-output-to-file - with-output-to-binary-file - with-output-to-port write write-char write-line - write-string) - (export (runtime rep) - *current-output-port*)) + write-string)) (define-package (runtime interrupt-handler) (files "intrpt") @@ -2141,10 +2155,10 @@ MIT in each case. |# graphics-clear graphics-close graphics-coordinate-limits - graphics-device? graphics-device-coordinate-limits graphics-device/descriptor graphics-device/properties + graphics-device? graphics-disable-buffering graphics-drag-cursor graphics-draw-line @@ -2161,17 +2175,16 @@ MIT in each case. |# graphics-set-drawing-mode graphics-set-line-style graphics-type-available? - make-graphics-device - make-graphics-device-type - image? image/descriptor image/destroy - image/width - image/height image/draw image/draw-subimage image/fill-from-byte-vector -)) + image/height + image/width + image? + make-graphics-device + make-graphics-device-type)) (define-package (runtime x-graphics) (files "x11graph") @@ -2271,8 +2284,7 @@ MIT in each case. |# (import (runtime graphics) register-graphics-device-type make-image-type - image/create - ) + image/create) (initialization (initialize-package!))) (define-package (runtime starbase-graphics) diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm index 700b605d7..2a280a027 100644 --- a/v7/src/runtime/uerror.scm +++ b/v7/src/runtime/uerror.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: uerror.scm,v 14.34 1992/11/03 22:41:45 jinx Exp $ +$Id: uerror.scm,v 14.35 1993/10/21 11:49:55 cph Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -903,7 +903,7 @@ MIT in each case. |# (let ((frame (continuation/first-subproblem continuation))) (if (apply-frame? frame) (let ((object (apply-frame/operand frame 0))) - (let ((port (nearest-cmdl/port))) + (let ((port (notification-output-port))) (fresh-line port) (write-string ";Automagically impurifying an object..." port)) (impurify object) diff --git a/v7/src/runtime/usrint.scm b/v7/src/runtime/usrint.scm index 59199fcf6..ded4d5062 100644 --- a/v7/src/runtime/usrint.scm +++ b/v7/src/runtime/usrint.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: usrint.scm,v 1.8 1993/10/16 10:10:39 cph Exp $ +$Id: usrint.scm,v 1.9 1993/10/21 11:49:56 cph Exp $ Copyright (c) 1991-93 Massachusetts Institute of Technology @@ -47,8 +47,11 @@ MIT in each case. |# (string-append prompt suffix))) (define (prompt-for-command-expression prompt #!optional port) - (let ((prompt (canonicalize-prompt prompt " ")) - (port (if (default-object? port) (nearest-cmdl/port) port)) + (let ((prompt + (if (string-null? prompt) + prompt + (canonicalize-prompt prompt " "))) + (port (if (default-object? port) (interaction-i/o-port) port)) (level (nearest-cmdl/level))) (let ((operation (port/operation port 'PROMPT-FOR-COMMAND-EXPRESSION))) (if operation @@ -70,7 +73,7 @@ MIT in each case. |# (define (prompt-for-expression prompt #!optional port) (let ((prompt (canonicalize-prompt prompt ": ")) - (port (if (default-object? port) (nearest-cmdl/port) port))) + (port (if (default-object? port) (interaction-i/o-port) port))) (let ((operation (port/operation port 'PROMPT-FOR-EXPRESSION))) (if operation (operation port prompt) @@ -91,7 +94,7 @@ MIT in each case. |# (hook/repl-eval #f (prompt-for-expression prompt (if (default-object? port) - (nearest-cmdl/port) + (interaction-i/o-port) port)) (if (default-object? environment) (nearest-repl/environment) @@ -99,8 +102,11 @@ MIT in each case. |# (nearest-repl/syntax-table))) (define (prompt-for-command-char prompt #!optional port) - (let ((prompt (canonicalize-prompt prompt " ")) - (port (if (default-object? port) (nearest-cmdl/port) port)) + (let ((prompt + (if (string-null? prompt) + prompt + (canonicalize-prompt prompt " "))) + (port (if (default-object? port) (interaction-i/o-port) port)) (level (nearest-cmdl/level))) (let ((operation (port/operation port 'PROMPT-FOR-COMMAND-CHAR))) (if operation @@ -129,7 +135,7 @@ MIT in each case. |# (define (prompt-for-confirmation prompt #!optional port) (let ((prompt (canonicalize-prompt prompt " (y or n)? ")) - (port (if (default-object? port) (nearest-cmdl/port) port))) + (port (if (default-object? port) (interaction-i/o-port) port))) (let ((operation (port/operation port 'PROMPT-FOR-CONFIRMATION))) (if operation (operation port prompt) diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index da4977af8..a7ac052bd 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: version.scm,v 14.164 1993/09/08 22:39:34 cph Exp $ +$Id: version.scm,v 14.165 1993/10/21 11:49:56 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -45,7 +45,7 @@ MIT in each case. |# '())) (add-system! microcode-system) (add-event-receiver! event:after-restore snarf-microcode-version!) - (add-identification! "Runtime" 14 164)) + (add-identification! "Runtime" 14 165)) (define microcode-system) diff --git a/v8/src/runtime/global.scm b/v8/src/runtime/global.scm index f0e7db1b0..8802b6458 100644 --- a/v8/src/runtime/global.scm +++ b/v8/src/runtime/global.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Id: global.scm,v 14.45 1992/12/22 20:59:33 cph Exp $ +$Id: global.scm,v 14.46 1993/10/21 11:49:45 cph Exp $ -Copyright (c) 1988-1992 Massachusetts Institute of Technology +Copyright (c) 1988-93 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -144,14 +144,9 @@ MIT in each case. |# (define with-values call-with-values) (define (write-to-string object #!optional max) - (if (default-object? max) (set! max false)) - (if (not max) - (with-output-to-string - (lambda () - (write object))) - (with-output-to-truncated-string max - (lambda () - (write object))))) + (if (or (default-object? max) (not max)) + (with-output-to-string (lambda () (write object))) + (with-output-to-truncated-string max (lambda () (write object))))) (define (pa procedure) (if (not (procedure? procedure)) @@ -266,7 +261,7 @@ MIT in each case. |# (no-print (lambda () unspecific))) (if (or (default-object? suppress-messages?) (not suppress-messages?)) - (let ((port (nearest-cmdl/port))) + (let ((port (notification-output-port))) (do-it (lambda () (fresh-line port) (write-string ";Dumping " port) diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm index f7809e80a..756dfdf7b 100644 --- a/v8/src/runtime/load.scm +++ b/v8/src/runtime/load.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: load.scm,v 14.44 1993/10/15 10:26:32 cph Exp $ +$Id: load.scm,v 14.45 1993/10/21 11:49:46 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -101,7 +101,7 @@ MIT in each case. |# (define (loading-message suppress-loading-message? pathname do-it) (if suppress-loading-message? (do-it) - (let ((port (nearest-cmdl/port))) + (let ((port (notification-output-port))) (fresh-line port) (write-string ";Loading " port) (write (enough-namestring pathname) port) @@ -478,7 +478,7 @@ MIT in each case. |# (define (loading-message fname suppress? kind) (if (not suppress?) - (let ((port (nearest-cmdl/port))) + (let ((port (notification-output-port))) (fresh-line port) (write-string kind port) (write-string (->namestring (->pathname fname))) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index acc6f112b..8595331b3 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Id: runtime.pkg,v 14.206 1993/10/21 04:52:50 cph Exp $ +$Id: runtime.pkg,v 14.207 1993/10/21 11:49:53 cph Exp $ Copyright (c) 1988-1993 Massachusetts Institute of Technology @@ -231,8 +231,7 @@ MIT in each case. |# compiled-procedure/lambda discard-debugging-info! load-debugging-info-on-demand? - uncompress-ports - ) + uncompress-ports) (export (runtime load) dbg-info-vector/purification-root dbg-info-vector? @@ -274,11 +273,9 @@ MIT in each case. |# dbg-continuation/source-code dbg-procedure? dbg-procedure/source-code - dbg-expression? - ) + dbg-expression?) (export (runtime compress) - uncompress-internal - ) + uncompress-internal) (initialization (initialize-package!))) (define-package (runtime console-i/o-port) @@ -614,6 +611,7 @@ MIT in each case. |# find-restart format-error-message hook/invoke-condition-handler + ignore-errors invoke-restart invoke-restart-interactively make-condition @@ -667,12 +665,20 @@ MIT in each case. |# (files "fileio") (parent ()) (export () + call-with-binary-input-file + call-with-binary-output-file + call-with-input-file + call-with-output-file open-binary-i/o-file open-binary-input-file open-binary-output-file open-i/o-file open-input-file - open-output-file) + open-output-file + with-input-from-binary-file + with-input-from-file + with-output-to-binary-file + with-output-to-file) (initialization (initialize-package!))) (define-package (runtime transcript) @@ -941,6 +947,12 @@ MIT in each case. |# close-input-port close-output-port close-port + current-input-port + current-output-port + error-output-port + guarantee-i/o-port + guarantee-input-port + guarantee-output-port i/o-port? input-port/channel input-port/copy @@ -955,9 +967,11 @@ MIT in each case. |# input-port/operation/read-string input-port/state input-port? + interaction-i/o-port make-i/o-port make-input-port make-output-port + notification-output-port output-port/channel output-port/copy output-port/custom-operation @@ -990,9 +1004,29 @@ MIT in each case. |# port/with-output-blocking-mode port/with-output-terminal-mode port? + set-current-input-port! + set-current-output-port! + set-error-output-port! set-input-port/state! + set-interaction-i/o-port! + set-notification-output-port! set-output-port/state! - set-port/state!) + set-port/state! + set-trace-output-port! + trace-output-port + with-error-output-port + with-input-from-port + with-interaction-i/o-port + with-notification-output-port + with-output-to-port + with-trace-output-port) + (export (runtime rep) + *current-input-port* + *current-output-port* + *error-output-port* + *interaction-i/o-port* + *notification-output-port* + *trace-output-port*) (export (runtime emacs-interface) set-port/thread-mutex!)) @@ -1000,12 +1034,8 @@ MIT in each case. |# (files "input") (parent ()) (export () - call-with-input-file - call-with-binary-input-file char-ready? - current-input-port eof-object? - guarantee-input-port input-port/char-ready? input-port/discard-char input-port/discard-chars @@ -1017,13 +1047,7 @@ MIT in each case. |# read read-char read-char-no-hang - read-string - set-current-input-port! - with-input-from-file - with-input-from-binary-file - with-input-from-port) - (export (runtime rep) - *current-input-port*) + read-string) (export (runtime primitive-io) eof-object)) @@ -1032,14 +1056,10 @@ MIT in each case. |# (parent ()) (export () beep - call-with-output-file - call-with-binary-output-file clear - current-output-port display flush-output fresh-line - guarantee-output-port newline output-port/discretionary-flush output-port/flush-output @@ -1049,16 +1069,10 @@ MIT in each case. |# output-port/write-substring output-port/x-size output-port/y-size - set-current-output-port! - with-output-to-file - with-output-to-binary-file - with-output-to-port write write-char write-line - write-string) - (export (runtime rep) - *current-output-port*)) + write-string)) (define-package (runtime interrupt-handler) (files "intrpt") @@ -2141,10 +2155,10 @@ MIT in each case. |# graphics-clear graphics-close graphics-coordinate-limits - graphics-device? graphics-device-coordinate-limits graphics-device/descriptor graphics-device/properties + graphics-device? graphics-disable-buffering graphics-drag-cursor graphics-draw-line @@ -2161,17 +2175,16 @@ MIT in each case. |# graphics-set-drawing-mode graphics-set-line-style graphics-type-available? - make-graphics-device - make-graphics-device-type - image? image/descriptor image/destroy - image/width - image/height image/draw image/draw-subimage image/fill-from-byte-vector -)) + image/height + image/width + image? + make-graphics-device + make-graphics-device-type)) (define-package (runtime x-graphics) (files "x11graph") @@ -2271,8 +2284,7 @@ MIT in each case. |# (import (runtime graphics) register-graphics-device-type make-image-type - image/create - ) + image/create) (initialization (initialize-package!))) (define-package (runtime starbase-graphics) -- 2.25.1