Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * | |
4 | * MLton is released under a BSD-style license. | |
5 | * See the file MLton-LICENSE for details. | |
6 | *) | |
7 | ||
8 | signature PRIM_IO_ARG = | |
9 | sig | |
10 | structure Vector: MONO_VECTOR | |
11 | structure VectorSlice: MONO_VECTOR_SLICE | |
12 | structure Array: MONO_ARRAY | |
13 | structure ArraySlice: MONO_ARRAY_SLICE | |
14 | sharing type Vector.elem = VectorSlice.elem | |
15 | = Array.elem = ArraySlice.elem | |
16 | sharing type Vector.vector = VectorSlice.vector | |
17 | = Array.vector = ArraySlice.vector | |
18 | sharing type VectorSlice.slice = ArraySlice.vector_slice | |
19 | sharing type Array.array = ArraySlice.array | |
20 | ||
21 | val someElem: Vector.elem | |
22 | ||
23 | eqtype pos | |
24 | val compare: pos * pos -> order | |
25 | end | |
26 | ||
27 | functor PrimIO (S: PRIM_IO_ARG): PRIM_IO = | |
28 | struct | |
29 | open S | |
30 | ||
31 | structure V = Vector | |
32 | structure VS = VectorSlice | |
33 | structure A = Array | |
34 | structure AS = ArraySlice | |
35 | ||
36 | type elem = A.elem | |
37 | type vector = V.vector | |
38 | type vector_slice = VS.slice | |
39 | type array = A.array | |
40 | type array_slice = AS.slice | |
41 | type pos = pos | |
42 | val compare = compare | |
43 | ||
44 | datatype reader = | |
45 | RD of {avail: unit -> int option, | |
46 | block: (unit -> unit) option, | |
47 | canInput: (unit -> bool) option, | |
48 | chunkSize: int, | |
49 | close: unit -> unit, | |
50 | endPos: (unit -> pos) option, | |
51 | getPos: (unit -> pos) option, | |
52 | ioDesc: OS.IO.iodesc option, | |
53 | name: string, | |
54 | readArr: (array_slice -> int) option, | |
55 | readArrNB: (array_slice -> int option) option, | |
56 | readVec: (int -> vector) option, | |
57 | readVecNB: (int -> vector option) option, | |
58 | setPos: (pos -> unit) option, | |
59 | verifyPos: (unit -> pos) option} | |
60 | ||
61 | datatype writer = | |
62 | WR of {block: (unit -> unit) option, | |
63 | canOutput: (unit -> bool) option, | |
64 | chunkSize: int, | |
65 | close: unit -> unit, | |
66 | endPos: (unit -> pos) option, | |
67 | getPos: (unit -> pos) option, | |
68 | ioDesc: OS.IO.iodesc option, | |
69 | name: string, | |
70 | setPos: (pos -> unit) option, | |
71 | verifyPos: (unit -> pos) option, | |
72 | writeArr: (array_slice -> int) option, | |
73 | writeArrNB: (array_slice -> int option) option, | |
74 | writeVec: (vector_slice -> int) option, | |
75 | writeVecNB: (vector_slice -> int option) option} | |
76 | ||
77 | ||
78 | fun liftExn name function cause = raise IO.Io {name = name, | |
79 | function = function, | |
80 | cause = cause} | |
81 | ||
82 | fun openVector v = | |
83 | let | |
84 | val name = "openVector" | |
85 | val closed = ref false | |
86 | val pos = ref 0 | |
87 | val eofPos = V.length v | |
88 | fun check f = if !closed | |
89 | then liftExn name f IO.ClosedStream | |
90 | else () | |
91 | fun const f c = fn _ => (check f; c) | |
92 | fun readVec f i = | |
93 | let | |
94 | val _ = check f | |
95 | val n = Int.min (i, eofPos - !pos) | |
96 | in | |
97 | VS.vector (VS.slice (v, !pos, SOME n)) before (pos := !pos + n) | |
98 | end | |
99 | fun readArr f sl = | |
100 | let | |
101 | val _ = check f | |
102 | val (buf, i, sz) = AS.base sl | |
103 | val n = Int.min (sz, eofPos - !pos) | |
104 | in | |
105 | AS.copyVec {src = VS.slice (v, !pos, SOME n), | |
106 | dst = buf, | |
107 | di = i}; | |
108 | pos := !pos + n; | |
109 | n | |
110 | end | |
111 | in | |
112 | RD {avail = const "avail" NONE, | |
113 | block = SOME (const "block" ()), | |
114 | canInput = SOME (const "canInput" true), | |
115 | chunkSize = 32, | |
116 | close = fn () => (closed := true), | |
117 | endPos = NONE, | |
118 | getPos = NONE, | |
119 | ioDesc = NONE, | |
120 | name = name, | |
121 | readArr = SOME (readArr "readArr"), | |
122 | readArrNB = SOME (SOME o (readArr "readVecNB")), | |
123 | readVec = SOME (readVec "readVec"), | |
124 | readVecNB = SOME (SOME o (readVec "readVecNB")), | |
125 | setPos = NONE, | |
126 | verifyPos = NONE} | |
127 | end | |
128 | ||
129 | fun nullRd () = | |
130 | let | |
131 | val name = "nullRd" | |
132 | val closed = ref false | |
133 | fun check f = if !closed | |
134 | then liftExn name f IO.ClosedStream | |
135 | else () | |
136 | fun const f c = fn _ => (check f; c) | |
137 | val empty = V.fromList [] | |
138 | in | |
139 | RD {avail = const "avail" NONE, | |
140 | block = SOME (const "block" ()), | |
141 | canInput = SOME (const "canInput" true), | |
142 | chunkSize = 1, | |
143 | close = fn () => (closed := true), | |
144 | endPos = NONE, | |
145 | getPos = NONE, | |
146 | ioDesc = NONE, | |
147 | name = name, | |
148 | readArr = SOME (const "readArr" 0), | |
149 | readArrNB = SOME (const "readArrNB" (SOME 0)), | |
150 | readVec = SOME (const "readVec" empty), | |
151 | readVecNB = SOME (const "readVecNB" (SOME empty)), | |
152 | setPos = NONE, | |
153 | verifyPos = NONE} | |
154 | end | |
155 | ||
156 | fun nullWr () = | |
157 | let | |
158 | val name = "nullWr" | |
159 | val closed = ref false | |
160 | fun check f = if !closed | |
161 | then liftExn name f IO.ClosedStream | |
162 | else () | |
163 | fun const f c = fn _ => (check f; c) | |
164 | fun function f g = fn x => (check f; g x) | |
165 | in | |
166 | WR {block = SOME (const "block" ()), | |
167 | canOutput = SOME (const "canOutput" true), | |
168 | chunkSize = 1, | |
169 | close = fn () => (closed := true), | |
170 | endPos = NONE, | |
171 | getPos = NONE, | |
172 | ioDesc = NONE, | |
173 | name = name, | |
174 | setPos = NONE, | |
175 | verifyPos = NONE, | |
176 | writeArr = SOME (function "writeArr" AS.length), | |
177 | writeArrNB = SOME (function "writeArrNB" (SOME o AS.length)), | |
178 | writeVec = SOME (function "writeVec" VS.length), | |
179 | writeVecNB = SOME (function "writeVecNB" (SOME o VS.length))} | |
180 | end | |
181 | ||
182 | fun doBlock (f, block: unit -> unit) x = (block (); valOf (f x)) | |
183 | fun doCanInput (f, canInput) x = if canInput () | |
184 | then SOME (f x) | |
185 | else NONE | |
186 | ||
187 | fun augmentReader (RD {name, chunkSize, | |
188 | readVec, readArr, readVecNB, readArrNB, | |
189 | block, canInput, avail, | |
190 | getPos, setPos, endPos, verifyPos, | |
191 | close, ioDesc}) = | |
192 | let | |
193 | fun augmentRead (readVec, readArr) = | |
194 | case (readVec, readArr) of | |
195 | (SOME readVec, SOME readArr) => (SOME readVec, SOME readArr) | |
196 | | (NONE, SOME readArr) => | |
197 | (SOME (fn i => | |
198 | let | |
199 | val buf = A.array (i, someElem) | |
200 | fun first j = AS.slice (buf, 0, SOME j) | |
201 | in | |
202 | (AS.vector o first) (readArr (first i)) | |
203 | end), | |
204 | SOME readArr) | |
205 | | (SOME readVec, NONE) => | |
206 | (SOME readVec, | |
207 | SOME (fn sl => | |
208 | let | |
209 | val (buf, i, sz) = AS.base sl | |
210 | val v = readVec sz | |
211 | val _ = A.copyVec {src = v, dst = buf, di = i} | |
212 | in | |
213 | V.length v | |
214 | end)) | |
215 | | (NONE, NONE) => (NONE, NONE) | |
216 | fun augmentReadNB (readVecNB, readArrNB) = | |
217 | case (readVecNB, readArrNB) of | |
218 | (SOME readVecNB, SOME readArrNB) => (SOME readVecNB, SOME readArrNB) | |
219 | | (NONE, SOME readArrNB) => | |
220 | (SOME (fn i => | |
221 | let | |
222 | val buf = A.array (i, someElem) | |
223 | fun first j = AS.slice (buf, 0, SOME j) | |
224 | in | |
225 | Option.map (AS.vector o first) (readArrNB (first i)) | |
226 | end), | |
227 | SOME readArrNB) | |
228 | | (SOME readVecNB, NONE) => | |
229 | (SOME readVecNB, | |
230 | SOME (fn sl => | |
231 | let | |
232 | val (buf, i, sz) = AS.base sl | |
233 | in | |
234 | case readVecNB sz of | |
235 | NONE => NONE | |
236 | | SOME v => (A.copyVec {src = v, dst = buf, di = i} | |
237 | ; SOME (V.length v)) | |
238 | end)) | |
239 | | (NONE, NONE) => (NONE, NONE) | |
240 | fun augmentSeq (readSeq, readSeqNB) = | |
241 | case (readSeq, readSeqNB) of | |
242 | (SOME readSeq, SOME readSeqNB) => (SOME readSeq, SOME readSeqNB) | |
243 | | (NONE, SOME readSeqNB) => | |
244 | (case block of | |
245 | NONE => NONE | |
246 | | SOME block => SOME (doBlock (readSeqNB, block)), | |
247 | SOME readSeqNB) | |
248 | | (SOME readSeq, NONE) => | |
249 | (SOME readSeq, | |
250 | case canInput of | |
251 | NONE => NONE | |
252 | | SOME canInput => SOME (doCanInput (readSeq, canInput))) | |
253 | | (NONE, NONE) => (NONE, NONE) | |
254 | ||
255 | val ((readVec,readArr),(readVecNB,readArrNB)) = | |
256 | (augmentRead (readVec, readArr), | |
257 | augmentReadNB (readVecNB, readArrNB)) | |
258 | val ((readVec,readVecNB),(readArr,readArrNB)) = | |
259 | (augmentSeq (readVec, readVecNB), | |
260 | augmentSeq (readArr, readArrNB)) | |
261 | in | |
262 | RD {name = name, chunkSize = chunkSize, | |
263 | readVec = readVec, readArr = readArr, | |
264 | readVecNB = readVecNB, readArrNB = readArrNB, | |
265 | block = block, canInput = canInput, avail = avail, | |
266 | getPos = getPos, setPos = setPos, | |
267 | endPos = endPos, verifyPos = verifyPos, | |
268 | close = close, ioDesc = ioDesc} | |
269 | end | |
270 | ||
271 | fun augmentWriter (WR {name, chunkSize, | |
272 | writeVec, writeArr, writeVecNB, writeArrNB, | |
273 | block, canOutput, | |
274 | getPos, setPos, endPos, verifyPos, | |
275 | close, ioDesc}) = | |
276 | let | |
277 | fun augmentWrite (writeVec, writeArr) = | |
278 | case (writeVec, writeArr) of | |
279 | (SOME writeVec, SOME writeArr) => (SOME writeVec, SOME writeArr) | |
280 | | (NONE, SOME writeArr) => | |
281 | (SOME (fn sl => | |
282 | writeArr | |
283 | (AS.full | |
284 | (A.tabulate (VS.length sl, fn i => VS.sub (sl, i))))), | |
285 | SOME writeArr) | |
286 | | (SOME writeVec, NONE) => | |
287 | (SOME writeVec, | |
288 | SOME (fn sl => writeVec (VS.full (AS.vector sl)))) | |
289 | | (NONE, NONE) => (NONE, NONE) | |
290 | fun augmentSeq (writeSeq, writeSeqNB) = | |
291 | case (writeSeq, writeSeqNB) of | |
292 | (SOME writeSeq, SOME writeSeqNB) => (SOME writeSeq, SOME writeSeqNB) | |
293 | | (NONE, SOME writeSeqNB) => | |
294 | (case block of | |
295 | NONE => NONE | |
296 | | SOME block => SOME (fn x => (block (); | |
297 | valOf (writeSeqNB x))), | |
298 | SOME writeSeqNB) | |
299 | | (SOME writeSeq, NONE) => | |
300 | (SOME writeSeq, | |
301 | case canOutput of | |
302 | NONE => NONE | |
303 | | SOME canOutput => SOME (fn x => (if canOutput () | |
304 | then SOME (writeSeq x) | |
305 | else NONE))) | |
306 | | (NONE, NONE) => (NONE, NONE) | |
307 | ||
308 | val ((writeVec,writeArr),(writeVecNB,writeArrNB)) = | |
309 | (augmentWrite (writeVec, writeArr), | |
310 | augmentWrite (writeVecNB, writeArrNB)) | |
311 | val ((writeVec,writeVecNB),(writeArr,writeArrNB)) = | |
312 | (augmentSeq (writeVec, writeVecNB), | |
313 | augmentSeq (writeArr, writeArrNB)) | |
314 | in | |
315 | WR {name = name, chunkSize = chunkSize, | |
316 | writeVec = writeVec, writeArr = writeArr, | |
317 | writeVecNB = writeVecNB, writeArrNB = writeArrNB, | |
318 | block = block, canOutput = canOutput, | |
319 | getPos = getPos, setPos = setPos, | |
320 | endPos = endPos, verifyPos = verifyPos, | |
321 | close = close, ioDesc = ioDesc} | |
322 | end | |
323 | end |