1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; Current input, output, error, and noise ports.
; These two ports are needed by the VM for the READ-BYTE and WRITE-BYTE
; opcodes.
(define $current-input-port (enum current-port-marker current-input-port))
(define $current-output-port (enum current-port-marker current-output-port))
(define $current-error-port (make-fluid #f))
(define $current-noise-port (make-fluid #f)) ; defaults to the error port
(define (current-input-port)
(fluid $current-input-port))
(define (current-output-port)
(fluid $current-output-port))
(define (current-error-port)
(fluid $current-error-port))
(define (current-noise-port)
(fluid $current-noise-port))
(define (initialize-i/o input output error thunk)
(with-current-ports input output error thunk))
(define (with-current-ports in out error thunk)
(let-fluids $current-input-port in
$current-output-port out
$current-error-port error
$current-noise-port error
thunk))
(define (call-with-current-input-port port thunk)
(let-fluid $current-input-port port thunk))
(define (call-with-current-output-port port thunk)
(let-fluid $current-output-port port thunk))
(define (call-with-current-noise-port port thunk)
(let-fluid $current-noise-port port thunk))
(define (silently thunk)
(call-with-current-noise-port (make-null-output-port) thunk))
;----------------
; Procedures with default port arguments.
; We probably lose a lot of speed here as compared with the
; specialized VM instructions.
(define (newline . port-option)
(write-char #\newline (output-port-option port-option)))
(define (byte-ready? . port-option)
(real-byte-ready? (input-port-option port-option)))
; CHAR-READY? sucks
(define (char-ready? . port-option)
(real-char-ready? (input-port-option port-option)))
(define (output-port-option port-option)
(cond ((null? port-option) (current-output-port))
((null? (cdr port-option)) (car port-option))
(else
(assertion-violation 'write-mumble
"too many arguments" port-option))))
(define (input-port-option port-option)
(cond ((null? port-option) (current-input-port))
((null? (cdr port-option)) (car port-option))
(else
(assertion-violation 'read-mumble
"read-mumble: too many arguments" port-option))))
|
