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