Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/system/Basis/Implementation/IO/prim-io-fn.sml
ViewVC logotype

Annotation of /sml/trunk/src/system/Basis/Implementation/IO/prim-io-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1398 - (view) (download)

1 : monnier 416 (* prim-io-fn.sml
2 :     *
3 :     * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :     *
5 :     *)
6 :     functor PrimIO (
7 :    
8 :     structure Vector : MONO_VECTOR
9 :     structure Array : MONO_ARRAY
10 : mblume 1350 where type vector = Vector.vector
11 :     where type elem = Vector.elem
12 :     structure VectorSlice : MONO_VECTOR_SLICE
13 :     where type vector = Vector.vector
14 :     where type elem = Vector.elem
15 :     structure ArraySlice : MONO_ARRAY_SLICE
16 :     where type elem = Vector.elem
17 :     where type array = Array.array
18 :     where type vector = Vector.vector
19 :     where type vector_slice = VectorSlice.slice
20 : monnier 416 val someElem : Vector.elem
21 :     eqtype pos
22 :     val compare : (pos * pos) -> order
23 :    
24 :     ) : PRIM_IO = struct
25 :    
26 :     structure A = Array
27 : mblume 1350 structure AS = ArraySlice
28 : monnier 416 structure V = Vector
29 : mblume 1350 structure VS = VectorSlice
30 : monnier 416
31 :     type elem = A.elem
32 :     type vector = V.vector
33 : mblume 1381 type vector_slice = VS.slice
34 : monnier 416 type array = A.array
35 : mblume 1381 type array_slice = AS.slice
36 :    
37 : monnier 416 type pos = pos
38 :    
39 :     val compare = compare
40 :    
41 :     datatype reader = RD of {
42 :     name : string,
43 :     chunkSize : int,
44 :     readVec : (int -> vector) option,
45 : mblume 1381 readArr : (array_slice -> int) option,
46 : monnier 416 readVecNB : (int -> vector option) option,
47 : mblume 1381 readArrNB : (array_slice -> int option) option,
48 : monnier 416 block : (unit -> unit) option,
49 :     canInput : (unit -> bool) option,
50 :     avail : unit -> int option,
51 :     getPos : (unit -> pos) option,
52 :     setPos : (pos -> unit) option,
53 :     endPos : (unit -> pos) option,
54 :     verifyPos : (unit -> pos) option,
55 :     close : unit -> unit,
56 :     ioDesc : OS.IO.iodesc option
57 :     }
58 :    
59 :     datatype writer = WR of {
60 :     name : string,
61 :     chunkSize : int,
62 : mblume 1381 writeVec : (vector_slice -> int) option,
63 :     writeArr : (array_slice -> int) option,
64 :     writeVecNB : (vector_slice -> int option) option,
65 :     writeArrNB : (array_slice -> int option) option,
66 : monnier 416 block : (unit -> unit) option,
67 :     canOutput : (unit -> bool) option,
68 :     getPos : (unit -> pos) option,
69 :     setPos : (pos -> unit) option,
70 :     endPos : (unit -> pos) option,
71 :     verifyPos : (unit -> pos) option,
72 :     close : unit -> unit,
73 :     ioDesc : OS.IO.iodesc option
74 :     }
75 :    
76 :     fun blockingOperation (f, block) x = (block (); Option.valOf (f x))
77 :    
78 :     fun nonblockingOperation (read, canInput) x =
79 :     if (canInput()) then SOME(read x) else NONE
80 :    
81 :     fun augmentReader (RD rd) = let
82 :     fun readaToReadv reada n = let
83 :     val a = A.array(n, someElem)
84 : mblume 1381 val n = reada (AS.full a)
85 : monnier 416 in
86 : mblume 1350 AS.vector (AS.slice (a, 0, SOME n))
87 : monnier 416 end
88 :     fun readaToReadvNB readaNB n = let
89 :     val a = A.array(n, someElem)
90 :     in
91 : mblume 1381 case readaNB (AS.full a)
92 : mblume 1350 of SOME n' => SOME(AS.vector (AS.slice(a, 0, SOME n')))
93 : monnier 416 | NONE => NONE
94 :     (* end case *)
95 :     end
96 : mblume 1381 fun readvToReada readv asl = let
97 :     val (a, start, nelems) = AS.base asl
98 : monnier 416 val v = readv nelems
99 :     val len = V.length v
100 :     in
101 : mblume 1381 A.copyVec {dst=a, di=start, src=v};
102 : monnier 416 len
103 :     end
104 : mblume 1381 fun readvToReadaNB readvNB asl = let
105 :     val (a, start, nelems) = AS.base asl
106 :     in
107 :     case readvNB nelems
108 :     of SOME v => let
109 :     val len = V.length v
110 :     in
111 :     A.copyVec {dst=a, di=start, src=v};
112 :     SOME len
113 :     end
114 :     | NONE => NONE
115 :     (* end case *)
116 :     end
117 : monnier 416 val readVec' = (case rd
118 :     of {readVec=SOME f, ...} => SOME f
119 :     | {readArr=SOME f, ...} => SOME(readaToReadv f)
120 :     | {readVecNB=SOME f, block=SOME b, ...} =>
121 :     SOME(blockingOperation (f, b))
122 :     | {readArrNB=SOME f, block=SOME b, ...} =>
123 :     SOME(blockingOperation (readaToReadvNB f, b))
124 :     | _ => NONE
125 :     (* end case *))
126 :     val readArr' = (case rd
127 :     of {readArr=SOME f, ...} => SOME f
128 :     | {readVec=SOME f, ...} => SOME(readvToReada f)
129 :     | {readArrNB=SOME f, block=SOME b, ...} =>
130 :     SOME(blockingOperation(f, b))
131 :     | {readVecNB=SOME f,block=SOME b, ...} =>
132 :     SOME(blockingOperation(readvToReadaNB f, b))
133 :     | _ => NONE
134 :     (* end case *))
135 :     val readVecNB' = (case rd
136 :     of {readVecNB=SOME f, ...} => SOME f
137 :     | {readArrNB=SOME f, ...} => SOME(readaToReadvNB f)
138 :     | {readVec=SOME f, canInput=SOME can, ...} =>
139 :     SOME(nonblockingOperation(f, can))
140 :     | {readArr=SOME f, canInput=SOME can, ...} =>
141 :     SOME(nonblockingOperation(readaToReadv f, can))
142 :     | _ => NONE
143 :     (* end case *))
144 :     val readArrNB' = (case rd
145 :     of {readArrNB=SOME f, ...} => SOME f
146 :     | {readVecNB=SOME f, ...} => SOME(readvToReadaNB f)
147 :     | {readArr=SOME f, canInput=SOME can, ...} =>
148 :     SOME(nonblockingOperation (f, can))
149 :     | {readVec=SOME f, canInput=SOME can, ...} =>
150 :     SOME(nonblockingOperation (readvToReada f, can))
151 :     | _ => NONE
152 :     (* end case *))
153 :     in RD{
154 :     name= #name rd, chunkSize= #chunkSize rd,
155 :     readVec=readVec', readArr=readArr',
156 :     readVecNB=readVecNB', readArrNB=readArrNB',
157 :     block= #block rd, canInput = #canInput rd, avail = #avail rd,
158 :     getPos = #getPos rd, setPos = #setPos rd, endPos = #endPos rd,
159 :     verifyPos = #verifyPos rd,
160 :     close= #close rd,
161 :     ioDesc= #ioDesc rd
162 :     }
163 :     end
164 :    
165 :     fun augmentWriter (WR wr) = let
166 : mblume 1381 fun writevToWritea writev asl = writev (VS.full (AS.vector asl))
167 :     fun writeaToWritev writea vsl =
168 :     case VS.length vsl of
169 :     0 => 0
170 :     | n => let val a = A.array (n, VS.sub (vsl, 0))
171 :     in
172 :     AS.copyVec { src = VS.subslice (vsl, 1, NONE),
173 :     dst = a, di = 1 };
174 :     writea (AS.full a)
175 :     end
176 :     fun writeaToWritevNB writeaNB vsl =
177 :     case VS.length vsl of
178 :     0 => SOME 0
179 :     | n => let val a = A.array (n, VS.sub (vsl, 0))
180 :     in
181 :     AS.copyVec { src = VS.subslice (vsl, 1, NONE),
182 :     dst = a, di = 1 };
183 :     writeaNB (AS.full a)
184 :     end
185 : monnier 416 val writeVec' = (case wr
186 :     of {writeVec=SOME f, ...} => SOME f
187 :     | {writeArr=SOME f, ...} => SOME(writeaToWritev f)
188 :     | {writeVecNB=SOME f, block=SOME b, ...} =>
189 :     SOME(fn i => (b(); Option.valOf(f i)))
190 :     | {writeArrNB=SOME f, block=SOME b, ...} =>
191 :     SOME(fn x => (b(); writeaToWritev (Option.valOf o f) x))
192 :     | _ => NONE
193 :     (* end case *))
194 :     val writeArr' = (case wr
195 :     of {writeArr=SOME f, ...} => SOME f
196 :     | {writeVec=SOME f, ...} => SOME(writevToWritea f)
197 :     | {writeArrNB=SOME f, block=SOME b, ...} => SOME(blockingOperation (f, b))
198 :     | {writeVecNB=SOME f,block=SOME b, ...} =>
199 :     SOME(blockingOperation (writevToWritea f, b))
200 :     | _ => NONE
201 :     (* end case *))
202 :     val writeVecNB' = (case wr
203 :     of {writeVecNB=SOME f, ...} => SOME f
204 :     | {writeArrNB=SOME f, ...} => SOME(writeaToWritevNB f)
205 :     | {writeVec=SOME f, canOutput=SOME can, ...} =>
206 :     SOME(nonblockingOperation (f, can))
207 :     | {writeArr=SOME f, canOutput=SOME can, ...} =>
208 :     SOME(nonblockingOperation (writeaToWritev f, can))
209 :     | _ => NONE
210 :     (* end case *))
211 :     val writeArrNB' = (case wr
212 :     of {writeArrNB=SOME f, ...} => SOME f
213 :     | {writeVecNB=SOME f, ...} => SOME(writevToWritea f)
214 :     | {writeArr=SOME f, canOutput=SOME can, ...} =>
215 :     SOME(nonblockingOperation (f, can))
216 :     | {writeVec=SOME f, canOutput=SOME can, ...} =>
217 :     SOME(nonblockingOperation (writevToWritea f, can))
218 :     | _ => NONE
219 :     (* end case *))
220 :     in WR{
221 :     name= #name wr, chunkSize= #chunkSize wr,
222 :     writeVec=writeVec', writeArr=writeArr',
223 :     writeVecNB=writeVecNB', writeArrNB=writeArrNB',
224 :     block= #block wr, canOutput = #canOutput wr,
225 :     getPos = #getPos wr, setPos = #setPos wr, endPos = #endPos wr,
226 :     verifyPos = #verifyPos wr,
227 :     close= #close wr,
228 :     ioDesc= #ioDesc wr
229 :     }
230 :     end
231 :    
232 : mblume 1398 fun openVector v = let
233 :     val pos = ref 0
234 :     val closed = ref false
235 :     fun checkClosed () = if !closed then raise IO.ClosedStream else ()
236 :     val len = V.length v
237 :     fun avail () = len - !pos
238 :     fun readV n = let
239 :     val p = !pos
240 :     val m = Int31Imp.min (n, len - p)
241 :     in
242 :     checkClosed ();
243 :     pos := p + m;
244 :     VS.vector (VS.slice (v, p, SOME m))
245 :     end
246 :     fun readA asl = let
247 :     val p = !pos
248 :     val (buf, i, n) = AS.base asl
249 :     val m = Int31Imp.min (n, len - p)
250 :     in
251 :     checkClosed ();
252 :     pos := p + m;
253 :     AS.copyVec { src = VS.slice (v, p, SOME m), dst = buf, di = i };
254 :     m
255 :     end
256 :     fun checked k () = (checkClosed (); k)
257 :     in
258 :     (* random access not supported because pos type is abstract *)
259 :     RD { name = "<vector>",
260 :     chunkSize = len,
261 :     readVec = SOME readV,
262 :     readArr = SOME readA,
263 :     readVecNB = SOME (SOME o readV),
264 :     readArrNB = SOME (SOME o readA),
265 :     block = SOME checkClosed,
266 :     canInput = SOME (checked true),
267 :     avail = SOME o avail,
268 :     getPos = NONE,
269 :     setPos = NONE,
270 :     endPos = NONE,
271 :     verifyPos = NONE,
272 :     close = fn () => closed := true,
273 :     ioDesc = NONE }
274 :     end
275 : monnier 416
276 : mblume 1398 fun nullRd () = let
277 :     val closed = ref false
278 :     fun checkClosed () = if !closed then raise IO.ClosedStream else ()
279 :     fun checked k _ = (checkClosed (); k)
280 :     in
281 :     RD { name = "<null>",
282 :     chunkSize = 1,
283 :     readVec = SOME (checked (V.fromList [])),
284 :     readArr = SOME (checked 0),
285 :     readVecNB = SOME (checked (SOME (V.fromList []))),
286 :     readArrNB = SOME (checked (SOME 0)),
287 :     block = SOME checkClosed,
288 :     canInput = SOME (checked true),
289 :     avail = fn () => SOME 0,
290 :     getPos = NONE,
291 :     setPos = NONE,
292 :     endPos = NONE,
293 :     verifyPos = NONE,
294 :     close = fn () => closed := true,
295 :     ioDesc = NONE }
296 :     end
297 :    
298 :     fun nullWr () = let
299 :     val closed = ref false
300 :     fun checkClosed () = if !closed then raise IO.ClosedStream else ()
301 :     fun checked k () = k
302 :     fun writeVec vsl = (checkClosed (); VS.length vsl)
303 :     fun writeArr asl = (checkClosed (); AS.length asl)
304 :     in
305 :     WR { name = "<null>",
306 :     chunkSize = 1,
307 :     writeVec = SOME writeVec,
308 :     writeArr = SOME writeArr,
309 :     writeVecNB = SOME (SOME o writeVec),
310 :     writeArrNB = SOME (SOME o writeArr),
311 :     block = SOME checkClosed,
312 :     canOutput = SOME (checked true),
313 :     getPos = NONE,
314 :     setPos = NONE,
315 :     endPos = NONE,
316 :     verifyPos = NONE,
317 :     close = fn () => closed := true,
318 :     ioDesc = NONE }
319 :     end
320 : monnier 416
321 : mblume 1398 end (* PrimIO *)

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0