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
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; Minimal full-I/O test system
(define (start arg in-channel out-channel error-channel)
(set! *error-channel* error-channel)
(set-exception-handlers! exception-handlers)
(let* ((ch (open-channel "small-test.image"
"small-test.image"
(enum open-channel-option input-file)
#f))
(out (output-channel->port out-channel))
(in (input-channel->port in-channel)))
(write-string "Hello " out)
(collect)
(if (< 0 (vector-length arg))
(write-block (vector-ref arg 0)
0
(string-length (vector-ref arg 0))
out))
(newline out)
(force-output out)
(let ((b (make-string 12 #\space)))
(channel-read b 0 12 ch)
(close-channel ch)
(write-string b out)
(newline out)
(force-output out))
(write-string "Eight chars> " out)
(force-output out)
(do ((i 0 (+ i 1)))
((= i 8))
(write-char (peek-char in) out)
(read-char in))
(newline out)
(force-output out)
(write-image "small-test.image" start "A small image")
0))
(define buffer-size 4) ; for testing
(define (output-channel->port channel)
(make-port #f
'text-codec
#f
(bitwise-ior (arithmetic-shift 1 (enum port-status-options
output))
(arithmetic-shift 1 (enum port-status-options
open-for-output)))
#f ; lock
channel
(make-byte-vector buffer-size 0)
0 buffer-size
#f #f))
(define (input-channel->port channel)
(make-port #f
'text-codec
#f
(bitwise-ior (arithmetic-shift 1 (enum port-status-options
input))
(arithmetic-shift 1 (enum port-status-options
open-for-input)))
#f ; lock
channel
(make-byte-vector buffer-size 0)
0 buffer-size
#f #f))
(define *error-channel* #f)
(define (error string . stuff)
(channel-write-string string *error-channel*)
(channel-newline *error-channel*)
(exit -1))
(define (message string)
(channel-write-string string *error-channel*)
(channel-newline *error-channel*))
(define (channel-write-string string channel)
(channel-write string
0
(string-length string)
channel))
(define (channel-newline channel)
(channel-write-string "
" channel))
(define (define-vm-exception-handler opcode proc)
(vector-set! vm-exception-handlers opcode proc))
(define vm-exception-handlers
(make-vector op-count #f))
(define-vm-exception-handler (enum op write-char)
(lambda (opcode reason char port)
(cond ((= reason (enum exception buffer-full/empty))
(force-output port)
(message "[overflow]")
(write-char char port))
(else
(apply signal-vm-exception opcode reason args)))))
(define-vm-exception-handler (enum op read-char)
(lambda (opcode reason port)
(cond ((= reason (enum exception buffer-full/empty))
(fill-buffer port)
(message "[underflow]")
(read-char port))
(else
(apply signal-vm-exception opcode reason args)))))
(define-vm-exception-handler (enum op peek-char)
(lambda (opcode reason port)
(cond ((= reason (enum exception buffer-full/empty))
(fill-buffer port)
(message "[underflow]")
(peek-char port))
(else
(apply signal-vm-exception opcode reason args)))))
(define-vm-exception-handler (enum op write-block)
(lambda (opcode reason thing start count port)
(cond ((= reason (enum exception buffer-full/empty))
(force-output port)
(write-buffer thing start count (port-data port)))
(else
(apply signal-vm-exception opcode reason args)))))
(define (force-output port)
(write-buffer (port-out-buffer port) 0 (port-out-index port) (port-data port))
(set-port-out-index! port 0))
(define (write-buffer buffer start count channel)
(let loop ((start start) (count count))
(let ((sent (channel-write buffer start count channel)))
(if (< sent count)
(loop (+ start sent) (- count sent))))))
(define (fill-buffer port)
(let ((got (channel-read (port-in-buffer port)
0
(code-byte-length (port-in-buffer port))
(port-data port))))
(cond ((= got 0)
(fill-buffer port))
(else
(set-port-in-index! port 0)
(set-port-in-limit! port got)))))
(define (write-string string port)
(let ((l (string-length string)))
(do ((i 0 (+ i 1)))
((= i l))
(write-char (string-ref string i) port))))
(define (newline port)
(write-char #\newline port))
|
