#| -*-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
(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)
(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))
#| -*-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
(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
(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)
(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)))))
(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)
#| -*-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
(define input-file-template)
(define output-file-template)
(define i/o-file-template)
+
+(define input-buffer-size 512)
+(define output-buffer-size 512)
\f
(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))
(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))
(and (not (string=? "\n" end-of-line))
end-of-line)))
\f
-(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)))
(set-channel-port! channel port)
port))
\f
+(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))
+\f
(define-structure (file-state (type vector)
(conc-name file-state/))
;; First two elements of this vector are required by the generic
#| -*-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
(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))))
(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)))
+\f
+(define (print-statistic statistic port)
+ (newline port)
+ (write-string (gc-statistic->string statistic) port))
(define (gc-statistic->string statistic)
(let* ((ticks/second 1000)
#| -*-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
(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)))))
\f
(define (pa procedure)
(if (not (procedure? procedure))
(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)
#| -*-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
\f
;;;; 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))
(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))
\f
;;;; Input Procedures
#| -*-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
(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)
(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)))
#| -*-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
\f
;;;; 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))
(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))
\f
;;;; Output Procedures
#| -*-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
(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)
#| -*-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
(define output-port/operation-names port/operation-names)
(define output-port/state port/state)
(define set-output-port/state! set-port/state!)
-
+\f
(define (input-port/operation port name)
(port/operation port
(case name
(define input-port/custom-operation input-port/operation)
(define output-port/custom-operation output-port/operation)
-\f
-;;;; 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)
+\f
+;;;; Constructors
(define (make-input-port operations state)
(make-port operations state 'MAKE-INPUT-PORT true false))
(lambda ()
(set! mode (read-mode port))
(write-mode port outside-mode))))
- (thunk))))
\ No newline at end of file
+ (thunk))))
+\f
+;;;; 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
#| -*-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
(*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
(lambda (interrupt-mask)
interrupt-mask
(unblock-thread-events)
- (with-errors-ignored
+ (ignore-errors
(lambda ()
((->cmdl-message message) cmdl)))
(call-with-current-continuation
=> (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))))
\f
(define (bind-abort-restart cmdl thunk)
(call-with-current-continuation
(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)
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
(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)))
\f
#| -*-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
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?
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)
find-restart
format-error-message
hook/invoke-condition-handler
+ ignore-errors
invoke-restart
invoke-restart-interactively
make-condition
(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)
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
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
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!))
(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
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))
(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
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")
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
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")
(import (runtime graphics)
register-graphics-device-type
make-image-type
- image/create
- )
+ image/create)
(initialization (initialize-package!)))
(define-package (runtime starbase-graphics)
#| -*-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
(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)
#| -*-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
(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
(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)
(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)
(nearest-repl/syntax-table)))
\f
(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
(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)
#| -*-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
'()))
(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)
#| -*-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
(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)))))
\f
(define (pa procedure)
(if (not (procedure? procedure))
(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)
#| -*-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
(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)
(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)))
#| -*-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
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?
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)
find-restart
format-error-message
hook/invoke-condition-handler
+ ignore-errors
invoke-restart
invoke-restart-interactively
make-condition
(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)
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
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
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!))
(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
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))
(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
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")
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
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")
(import (runtime graphics)
register-graphics-device-type
make-image-type
- image/create
- )
+ image/create)
(initialization (initialize-package!)))
(define-package (runtime starbase-graphics)
projects / mit-scheme.git / commitdiff