1 (* Copyright (C) 2002-2006 Henry Cejtin, Matthew Fluet, Suresh
2 * Jagannathan, and Stephen Weeks.
4 * MLton is released under a BSD-style license.
5 * See the file MLton-LICENSE for details.
8 signature PRIM_IO_ARG =
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
21 val someElem: Vector.elem
24 val compare: pos * pos -> order
27 functor PrimIO (S: PRIM_IO_ARG): PRIM_IO =
32 structure VS = VectorSlice
34 structure AS = ArraySlice
37 type vector = V.vector
38 type vector_slice = VS.slice
40 type array_slice = AS.slice
45 RD of {avail: unit -> int option,
46 block: (unit -> unit) option,
47 canInput: (unit -> bool) option,
50 endPos: (unit -> pos) option,
51 getPos: (unit -> pos) option,
52 ioDesc: OS.IO.iodesc option,
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}
62 WR of {block: (unit -> unit) option,
63 canOutput: (unit -> bool) option,
66 endPos: (unit -> pos) option,
67 getPos: (unit -> pos) option,
68 ioDesc: OS.IO.iodesc option,
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}
78 fun liftExn name function cause = raise IO.Io {name = name,
84 val name = "openVector"
85 val closed = ref false
87 val eofPos = V.length v
88 fun check f = if !closed
89 then liftExn name f IO.ClosedStream
91 fun const f c = fn _ => (check f; c)
95 val n = Int.min (i, eofPos - !pos)
97 VS.vector (VS.slice (v, !pos, SOME n)) before (pos := !pos + n)
102 val (buf, i, sz) = AS.base sl
103 val n = Int.min (sz, eofPos - !pos)
105 AS.copyVec {src = VS.slice (v, !pos, SOME n),
112 RD {avail = const "avail" NONE,
113 block = SOME (const "block" ()),
114 canInput = SOME (const "canInput" true),
116 close = fn () => (closed := true),
121 readArr = SOME (readArr "readArr"),
122 readArrNB = SOME (SOME o (readArr "readVecNB")),
123 readVec = SOME (readVec "readVec"),
124 readVecNB = SOME (SOME o (readVec "readVecNB")),
132 val closed = ref false
133 fun check f = if !closed
134 then liftExn name f IO.ClosedStream
136 fun const f c = fn _ => (check f; c)
137 val empty = V.fromList []
139 RD {avail = const "avail" NONE,
140 block = SOME (const "block" ()),
141 canInput = SOME (const "canInput" true),
143 close = fn () => (closed := true),
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)),
159 val closed = ref false
160 fun check f = if !closed
161 then liftExn name f IO.ClosedStream
163 fun const f c = fn _ => (check f; c)
164 fun function f g = fn x => (check f; g x)
166 WR {block = SOME (const "block" ()),
167 canOutput = SOME (const "canOutput" true),
169 close = fn () => (closed := true),
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))}
182 fun doBlock (f, block: unit -> unit) x = (block (); valOf (f x))
183 fun doCanInput (f, canInput) x = if canInput ()
187 fun augmentReader (RD {name, chunkSize,
188 readVec, readArr, readVecNB, readArrNB,
189 block, canInput, avail,
190 getPos, setPos, endPos, verifyPos,
193 fun augmentRead (readVec, readArr) =
194 case (readVec, readArr) of
195 (SOME readVec, SOME readArr) => (SOME readVec, SOME readArr)
196 | (NONE, SOME readArr) =>
199 val buf = A.array (i, someElem)
200 fun first j = AS.slice (buf, 0, SOME j)
202 (AS.vector o first) (readArr (first i))
205 | (SOME readVec, NONE) =>
209 val (buf, i, sz) = AS.base sl
211 val _ = A.copyVec {src = v, dst = buf, di = i}
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) =>
222 val buf = A.array (i, someElem)
223 fun first j = AS.slice (buf, 0, SOME j)
225 Option.map (AS.vector o first) (readArrNB (first i))
228 | (SOME readVecNB, NONE) =>
232 val (buf, i, sz) = AS.base sl
236 | SOME v => (A.copyVec {src = v, dst = buf, di = i}
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) =>
246 | SOME block => SOME (doBlock (readSeqNB, block)),
248 | (SOME readSeq, NONE) =>
252 | SOME canInput => SOME (doCanInput (readSeq, canInput)))
253 | (NONE, NONE) => (NONE, NONE)
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))
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}
271 fun augmentWriter (WR {name, chunkSize,
272 writeVec, writeArr, writeVecNB, writeArrNB,
274 getPos, setPos, endPos, verifyPos,
277 fun augmentWrite (writeVec, writeArr) =
278 case (writeVec, writeArr) of
279 (SOME writeVec, SOME writeArr) => (SOME writeVec, SOME writeArr)
280 | (NONE, SOME writeArr) =>
284 (A.tabulate (VS.length sl, fn i => VS.sub (sl, i))))),
286 | (SOME writeVec, NONE) =>
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) =>
296 | SOME block => SOME (fn x => (block ();
297 valOf (writeSeqNB x))),
299 | (SOME writeSeq, NONE) =>
303 | SOME canOutput => SOME (fn x => (if canOutput ()
304 then SOME (writeSeq x)
306 | (NONE, NONE) => (NONE, NONE)
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))
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}