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
163
164
165
166
167
168
169
170
|
; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING.
; Extensible ports
; Input ports
(define-record-type extensible-input-port
(local-data
methods)
())
(define make-extensible-input-port extensible-input-port-maker)
(define-record-type input-port-methods
(close-port
read-char
peek-char
char-ready?
current-column
current-row
)
())
(define make-input-port-methods input-port-methods-maker)
; Output ports
(define-record-type extensible-output-port
(local-data
methods)
())
(define make-extensible-output-port extensible-output-port-maker)
(define-record-type output-port-methods
(close-port
write-char
write-string
force-output
fresh-line
current-column
current-row
)
())
(define make-output-port-methods output-port-methods-maker)
; Operations
; CLOSE-PORT must work on both types of extensible ports.
(define-exception-handler (enum op close-port)
(lambda (opcode args)
(let ((port (car args)))
(cond ((extensible-input-port? port)
((input-port-methods-close-port
(extensible-input-port-methods port))
(extensible-input-port-local-data port)))
((extensible-output-port? port)
((output-port-methods-close-port
(extensible-output-port-methods port))
(extensible-output-port-local-data port)))
(else
(raise-port-exception opcode args))))))
(define (raise-port-exception opcode args)
(signal-exception opcode args))
; Predicates
; These won't work as the VM does not raise an exception when predicates are
; applied to records.
;(define-exception-handler (enum op input-port?)
; (lambda (opcode args)
; (extensible-input-port? (car args))))
;(define-exception-handler (enum op output-port?)
; (lambda (opcode args)
; (extensible-output-port? (car args))))
; These will work for any code loaded subsequently...
(define (input-port? thing)
(or ((structure-ref ports input-port?) thing)
(extensible-input-port? thing)))
(define (output-port? thing)
(or ((structure-ref ports output-port?) thing)
(extensible-output-port? thing)))
; Other methods
(define (define-input-port-method op method)
(define-exception-handler op
(lambda (opcode args)
(let ((port (car args)))
(if (extensible-input-port? port)
((method (extensible-input-port-methods port))
(extensible-input-port-local-data port))
(raise-port-exception opcode args))))))
(define-input-port-method (enum op read-char) input-port-methods-read-char)
(define-input-port-method (enum op peek-char) input-port-methods-peek-char)
(define-input-port-method (enum op char-ready?) input-port-methods-char-ready?)
(define (define-output-port-method op arg-count method)
(define-exception-handler op
(case arg-count
((0)
(lambda (opcode args)
(let ((port (car args)))
(if (extensible-output-port? port)
((method (extensible-output-port-methods port))
(extensible-output-port-local-data port))
(raise-port-exception opcode args)))))
((1)
(lambda (opcode args)
(let ((port (cadr args)))
(if (extensible-output-port? port)
((method (extensible-output-port-methods port))
(extensible-output-port-local-data port)
(car args))
(raise-port-exception opcode args))))))))
(define-output-port-method (enum op write-char)
1 output-port-methods-write-char)
(define-output-port-method (enum op write-string)
1 output-port-methods-write-string)
(define-output-port-method (enum op force-output)
0 output-port-methods-force-output)
(define (make-new-port-method id input-method output-method default)
(lambda (port)
(cond ((extensible-input-port? port)
((input-method (extensible-input-port-methods port))
(extensible-input-port-local-data port)))
((extensible-output-port? port)
((output-method (extensible-output-port-methods port))
(extensible-output-port-local-data port)))
(else
(default port)))))
(define current-column
(make-new-port-method 'current-column
input-port-methods-current-column
output-port-methods-current-column
(lambda (port) #f)))
(define current-row
(make-new-port-method 'current-row
input-port-methods-current-row
output-port-methods-current-row
(lambda (port) #f)))
(define (make-new-output-port-method id method default)
(lambda (port)
(if (extensible-output-port? port)
((method (extensible-output-port-methods port))
(extensible-output-port-local-data port))
(default port))))
(define fresh-line
(make-new-output-port-method 'fresh-line
output-port-methods-fresh-line
newline))
(define force-output (structure-ref ports force-output))
|
