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/branches/SMLNJ/src/compiler/PervEnv/IO/text-io-fn.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/compiler/PervEnv/IO/text-io-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 143 - (view) (download)

1 : monnier 16 (* text-io-fn.sml
2 :     *
3 :     * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :     *
5 :     * QUESTION: what operations should raise exceptions when the stream is
6 :     * closed?
7 :     *
8 :     *)
9 :    
10 :     functor TextIOFn (
11 :    
12 :     structure OSPrimIO : sig
13 :     include OS_PRIM_IO
14 :     val stdIn : unit -> PrimIO.reader
15 :     val stdOut : unit -> PrimIO.writer
16 :     val stdErr : unit -> PrimIO.writer
17 :     val strReader : string -> PrimIO.reader
18 :     end
19 :     where PrimIO = TextPrimIO
20 :    
21 :     ) : TEXT_IO = struct
22 :    
23 :     structure PIO = OSPrimIO.PrimIO
24 :     structure A = CharArray
25 :     structure V = CharVector
26 :    
27 :     (* an element for initializing buffers *)
28 :     val someElem = #"\000"
29 :    
30 :     (** Fast, but unsafe version (from CharVector) **
31 :     val vecSub = InlineT.CharVector.sub
32 :     val arrUpdate = InlineT.CharArray.update
33 :     (* fast vector extract operation. This should never be called with
34 :     * a length of 0.
35 :     *)
36 :     fun vecExtract (v, base, optLen) = let
37 :     val len = V.length v
38 :     fun newVec n = let
39 :     val newV = Assembly.A.create_s n
40 :     fun fill i = if (i < n)
41 :     then (
42 :     InlineT.CharVector.update(newV, i, vecSub(v, base+i));
43 :     fill(i+1))
44 :     else ()
45 :     in
46 :     fill 0; newV
47 :     end
48 :     in
49 :     case (base, optLen)
50 :     of (0, NONE) => v
51 :     | (_, NONE) => newVec (len - base)
52 :     | (_, SOME n) => newVec n
53 :     (* end case *)
54 :     end
55 :     **)
56 :     val vecExtract = V.extract
57 :     val vecSub = V.sub
58 :     val arrUpdate = A.update
59 :     val substringBase = Substring.base
60 :     val empty = ""
61 :    
62 :     structure StreamIO =
63 :     struct
64 :     type vector = V.vector
65 :     type elem = V.elem
66 :     type reader = PIO.reader
67 :     type writer = PIO.writer
68 :     type pos = PIO.pos
69 :    
70 :     (*** Functional input streams ***)
71 :     datatype instream = ISTRM of (in_buffer * int)
72 :     and in_buffer = IBUF of {
73 :     basePos : pos option,
74 :     more : more ref,
75 :     data : vector,
76 :     info : info
77 :     }
78 :     and more
79 :     = MORE of in_buffer (* forward link to additional data *)
80 :     | NOMORE (* placeholder for forward link *)
81 :     | TERMINATED (* termination of the stream *)
82 :    
83 :     and info = INFO of {
84 :     reader : reader,
85 :     readVec : int -> vector,
86 :     readVecNB : (int -> vector) option,
87 :     closed : bool ref,
88 :     getPos : unit -> pos option,
89 :     tail : more ref ref, (* points to the more cell of the last buffer *)
90 :     cleanTag : CleanIO.tag
91 :     }
92 :    
93 :     fun infoOfIBuf (IBUF{info, ...}) = info
94 :     fun chunkSzOfIBuf buf = let
95 :     val INFO{reader=PIO.RD{chunkSize, ...}, ...} = infoOfIBuf buf
96 :     in
97 :     chunkSize
98 :     end
99 :     fun readVec (IBUF{info=INFO{readVec=f, ...}, ...}) = f
100 :    
101 :     fun inputExn (INFO{reader=PIO.RD{name, ...}, ...}, mlOp, exn) =
102 :     raise IO.Io{function=mlOp, name=name, cause=exn}
103 :    
104 :     (* this exception is raised by readVecNB in the blocking case *)
105 :     exception WouldBlock
106 :    
107 :     datatype more_data = EOF | DATA of in_buffer
108 :    
109 :     fun extendStream (readFn, mlOp, buf as IBUF{more, info, ...}) = (let
110 :     val INFO{getPos, tail, ...} = info
111 :     val basePos = getPos()
112 :     val chunk = readFn (chunkSzOfIBuf buf)
113 :     in
114 :     if (V.length chunk = 0)
115 :     then EOF
116 :     else let
117 :     val newMore = ref NOMORE
118 :     val buf' = IBUF{
119 :     basePos = basePos, data = chunk,
120 :     more = newMore, info = info
121 :     }
122 :     in
123 :     more := MORE buf';
124 :     tail := newMore;
125 :     DATA buf'
126 :     end
127 :     end
128 :     handle ex => inputExn(info, mlOp, ex))
129 :    
130 :     fun getBuffer (readFn, mlOp) (buf as IBUF{more, info, ...}) = (
131 :     case !more
132 :     of TERMINATED => EOF
133 :     | NOMORE => extendStream (readFn, mlOp, buf)
134 :     | (MORE buf') => DATA buf'
135 :     (* end case *))
136 :    
137 :     (* read a chunk that is at least the specified size *)
138 :     fun readChunk buf = let
139 :     val INFO{readVec, reader=PIO.RD{chunkSize, ...}, ...} =
140 :     infoOfIBuf buf
141 :     in
142 :     case (chunkSize - 1)
143 :     of 0 => (fn n => readVec n)
144 :     | k => (* round up to next multiple of chunkSize *)
145 :     (fn n => readVec(Int.quot((n+k), chunkSize) * chunkSize))
146 :     (* end case *)
147 :     end
148 :    
149 :     fun generalizedInput getBuf = let
150 :     fun get (ISTRM(buf as IBUF{data, ...}, pos)) = let
151 :     val len = V.length data
152 :     in
153 :     if (pos < len)
154 :     then (vecExtract(data, pos, NONE), ISTRM(buf, len))
155 :     else (case (getBuf buf)
156 :     of EOF => (empty, ISTRM(buf, len))
157 :     | (DATA rest) => get (ISTRM(rest, 0))
158 :     (* end case *))
159 :     end
160 :     in
161 :     get
162 :     end
163 :    
164 :    
165 :     (* terminate an input stream *)
166 :     fun terminate (INFO{tail, cleanTag, ...}) = (case !tail
167 :     of (m as ref NOMORE) => (
168 :     CleanIO.removeCleaner cleanTag;
169 :     m := TERMINATED)
170 :     | (m as ref TERMINATED) => ()
171 :     (* end case *))
172 :    
173 :     (* find the end of the stream *)
174 :     fun findEOS (IBUF{more=ref(MORE buf), ...}) = findEOS buf
175 :     | findEOS (buf as IBUF{data, ...}) = ISTRM(buf, V.length data)
176 :    
177 :     fun input (strm as ISTRM(buf, _)) =
178 :     generalizedInput (getBuffer (readVec buf, "input")) strm
179 :     fun input1 (ISTRM(buf, pos)) = let
180 :     val IBUF{data, more, ...} = buf
181 :     in
182 :     if (pos < V.length data)
183 :     then SOME(vecSub(data, pos), ISTRM(buf, pos+1))
184 :     else (case !more
185 :     of (MORE buf) => input1 (ISTRM(buf, 0))
186 :     | NOMORE => (
187 :     case extendStream (readVec buf, "input1", buf)
188 :     of EOF => NONE
189 :     | (DATA rest) => input1 (ISTRM(rest, 0))
190 :     (* end case *))
191 :     | TERMINATED => NONE
192 :     (* end case *))
193 :     end
194 :     fun inputN (ISTRM(buf, pos), n) = let
195 :     fun join (item, (list, strm)) = (item::list, strm)
196 :     fun inputList (buf as IBUF{data, ...}, i, n) = let
197 :     val len = V.length data
198 :     val remain = len-i
199 :     in
200 :     if (remain >= n)
201 :     then ([vecExtract(data, i, SOME n)], ISTRM(buf, i+n))
202 :     else join (
203 :     vecExtract(data, i, NONE),
204 :     nextBuf(buf, n-remain))
205 :     end
206 :     and nextBuf (buf as IBUF{more, data, ...}, n) = (case !more
207 :     of (MORE buf) => inputList (buf, 0, n)
208 :     | NOMORE => (
209 :     case extendStream (readVec buf, "inputN", buf)
210 :     of EOF => ([], ISTRM(buf, V.length data))
211 :     | (DATA rest) => inputList (rest, 0, n)
212 :     (* end case *))
213 :     | TERMINATED => ([], ISTRM(buf, V.length data))
214 :     (* end case *))
215 :     val (data, strm) = inputList (buf, pos, n)
216 :     in
217 :     (V.concat data, strm)
218 :     end
219 :     fun inputAll (strm as ISTRM(buf, _)) = let
220 :     val INFO{reader=PIO.RD{avail, ...}, ...} = infoOfIBuf buf
221 :     (* read a chunk that is as large as the available input. Note
222 :     * that for systems that use CR-LF for #"\n", the size will be
223 :     * too large, but this should be okay.
224 :     *)
225 :     fun bigChunk _ = let
226 :     val delta = (case avail()
227 :     of NONE => chunkSzOfIBuf buf
228 :     | (SOME n) => n
229 :     (* end case *))
230 :     in
231 :     readChunk buf delta
232 :     end
233 :     val bigInput =
234 :     generalizedInput (getBuffer (bigChunk, "inputAll"))
235 :     fun loop (v, strm) =
236 :     if (V.length v = 0) then [] else v :: loop(bigInput strm)
237 :     val data = V.concat (loop (bigInput strm))
238 : monnier 143 in data
239 : monnier 16 end
240 :     (* Return SOME k, if k <= amount characters can be read without blocking. *)
241 :     fun canInput (strm as ISTRM(buf, pos), amount) = let
242 :     val readVecNB = (case buf
243 :     of (IBUF{info as INFO{readVecNB=NONE, ...}, ...}) =>
244 :     inputExn(info, "canInput", IO.NonblockingNotSupported)
245 :     | (IBUF{info=INFO{readVecNB=SOME f, ...}, ...}) => f
246 :     (* end case *))
247 :     fun tryInput (buf as IBUF{data, ...}, i, n) = let
248 :     val len = V.length data
249 :     val remain = len - i
250 :     in
251 :     if (remain >= n)
252 :     then SOME n
253 :     else nextBuf (buf, n - remain)
254 :     end
255 :     and nextBuf (IBUF{more, ...}, n) = (case !more
256 :     of (MORE buf) => tryInput (buf, 0, n)
257 :     | TERMINATED => SOME(amount - n)
258 :     | NOMORE => ((
259 :     case extendStream (readVecNB, "canInput", buf)
260 :     of EOF => SOME(amount - n)
261 :     | (DATA b) => tryInput (b, 0, n)
262 :     (* end case *))
263 :     handle IO.Io{cause=WouldBlock, ...} => SOME(amount - n))
264 :     (* end case *))
265 :     in
266 :     if (amount < 0)
267 :     then raise Size
268 :     else tryInput (buf, pos, amount)
269 :     end
270 :     fun closeIn (ISTRM(buf, _)) = (case (infoOfIBuf buf)
271 :     of INFO{closed=ref true, ...} => ()
272 :     | (info as INFO{closed, reader=PIO.RD{close, ...}, ...}) => (
273 :     terminate info;
274 :     closed := true;
275 :     close() handle ex => inputExn(info, "closeIn", ex))
276 :     (* end case *))
277 :     fun endOfStream (ISTRM(buf, pos)) = (case buf
278 :     of (IBUF{more=ref(MORE _), ...}) => false
279 :     | (IBUF{more, data, info=INFO{closed, ...}, ...}) =>
280 :     if (pos = V.length data)
281 :     then (case (!more, !closed)
282 :     of (NOMORE, false) => (
283 :     case extendStream (readVec buf, "endOfStream", buf)
284 :     of EOF => true
285 :     | _ => false
286 :     (* end case *))
287 :     | _ => true
288 :     (* end case *))
289 :     else false
290 :     (* end case *))
291 : monnier 143 fun mkInstream (reader, data) = let
292 : monnier 16 val PIO.RD{readVec, readVecNB, getPos, setPos, ...} = reader
293 :     val readVec' = (case readVec
294 :     of NONE => (fn _ => raise IO.BlockingNotSupported)
295 :     | (SOME f) => f
296 :     (* end case *))
297 :     val readVecNB' = (case readVecNB
298 :     of NONE => NONE
299 :     | (SOME f) => SOME(fn arg => case (f arg)
300 :     of (SOME x) => x
301 :     | NONE => raise WouldBlock
302 :     (* end case *))
303 :     (* end case *))
304 :     val getPos = (case (getPos, setPos)
305 :     of (SOME f, SOME _) => (fn () => SOME(f()))
306 :     | _ => (fn () => NONE)
307 :     (* end case *))
308 :     val more = ref NOMORE
309 :     val closedFlg = ref false
310 :     val tag = CleanIO.addCleaner {
311 :     init = fn () => (closedFlg := true),
312 :     flush = fn () => (),
313 :     close = fn () => (closedFlg := true)
314 :     }
315 :     val info = INFO{
316 :     reader=reader, readVec=readVec', readVecNB=readVecNB',
317 :     closed = closedFlg, getPos = getPos, tail = ref more,
318 :     cleanTag = tag
319 :     }
320 : monnier 143 val buf =
321 : monnier 16 (** What should we do about the position in this case ?? **)
322 :     (** Suggestion: When building a stream with supplied initial data,
323 :     ** nothing can be said about the positions inside that initial
324 :     ** data (who knows where that data even came from!).
325 :     **)
326 : monnier 143 IBUF{
327 :     basePos = NONE, data=data,
328 : monnier 16 info=info, more=more}
329 :     in
330 :     ISTRM(buf, 0)
331 :     end
332 :    
333 :     fun getReader (ISTRM(buf, pos)) = let
334 :     val IBUF{data, info as INFO{reader, ...}, more, ...} = buf
335 :     fun getData (MORE(IBUF{data, more, ...})) = data :: getData(!more)
336 :     | getData _ = []
337 :     in
338 :     terminate info;
339 :     if (pos < V.length data)
340 :     then (
341 :     reader,
342 :     V.concat(vecExtract(data, pos, NONE) :: getData(!more))
343 :     )
344 :     else (reader, V.concat(getData(!more)))
345 :     end
346 :    
347 :     (** Position operations on instreams **)
348 :     datatype in_pos = INP of {
349 :     base : pos,
350 :     offset : int,
351 :     info : info
352 :     }
353 :    
354 :     fun getPosIn (ISTRM(buf, pos)) = (case buf
355 :     of IBUF{basePos=NONE, info, ...} =>
356 :     inputExn (info, "getPosIn", IO.RandomAccessNotSupported)
357 :     | IBUF{basePos=SOME p, info, ...} => INP{
358 :     base = p, offset = pos, info = info
359 :     }
360 :     (* end case *))
361 :     fun filePosIn (INP{base, offset=0, ...}) = base
362 :     | filePosIn (INP{base, offset, info}) = let
363 :     val INFO{reader=PIO.RD rd, readVec, ...} = info
364 :     in
365 :     case (#getPos rd, #setPos rd)
366 :     of (SOME getPos, SOME setPos) => let
367 :     val tmpPos = getPos()
368 :     fun readN 0 = ()
369 :     | readN n = (case V.length(readVec n)
370 :     of 0 => inputExn (
371 :     info, "filePosIn", Fail "bogus position")
372 :     | k => readN(n-k)
373 :     (* end case *))
374 :     in
375 :     setPos base;
376 :     readN offset;
377 :     getPos () before setPos tmpPos
378 :     end
379 :     | _ => raise Fail "filePosIn: impossible"
380 :     (* end case *)
381 :     end
382 :     fun setPosIn (pos as INP{info as INFO{reader, ...}, ...}) = let
383 :     val fpos = filePosIn pos
384 :     val (PIO.RD rd) = reader
385 :     in
386 :     terminate info;
387 :     Option.valOf (#setPos rd) fpos;
388 : monnier 143 mkInstream (PIO.RD rd, empty)
389 : monnier 16 end
390 :    
391 :     (** Text stream specific operations **)
392 :     fun inputLine (ISTRM(buf as IBUF{data, ...}, pos)) = let
393 :     fun join (item, (list, strm)) = (item::list, strm)
394 :     fun nextBuf (isEmpty, buf as IBUF{more, data, ...}) = let
395 :     fun last () =
396 :     (if isEmpty then [] else ["\n"], ISTRM(buf, V.length data))
397 :     in
398 :     case !more
399 :     of (MORE buf) => scanData (buf, 0)
400 :     | NOMORE => (
401 :     case extendStream (readVec buf, "inputLine", buf)
402 :     of EOF => last ()
403 :     | (DATA rest) => scanData (rest, 0)
404 :     (* end case *))
405 :     | TERMINATED => last ()
406 :     (* end case *)
407 :     end
408 :     and scanData (buf as IBUF{data, more, ...}, i) = let
409 :     val len = V.length data
410 :     fun scan j = if (j = len)
411 :     then join(vecExtract(data, i, NONE), nextBuf(false, buf))
412 :     else if (vecSub(data, j) = #"\n")
413 :     then ([vecExtract(data, i, SOME(j+1-i))], ISTRM(buf, j+1))
414 :     else scan (j+1)
415 :     in
416 :     scan i
417 :     end
418 :     val (data, strm) = if (V.length data = pos)
419 :     then nextBuf (true, buf)
420 :     else scanData (buf, pos)
421 :     in
422 :     (V.concat data, strm)
423 :     end
424 :    
425 :     (*** Output streams ***)
426 :     datatype outstream = OSTRM of {
427 :     buf : A.array,
428 :     pos : int ref,
429 :     closed : bool ref,
430 :     bufferMode : IO.buffer_mode ref,
431 :     writer : writer,
432 :     writeArr : {buf : A.array, i : int, sz : int option} -> unit,
433 :     writeVec : {buf : V.vector, i : int, sz : int option} -> unit,
434 :     cleanTag : CleanIO.tag
435 :     }
436 :    
437 :     fun outputExn (OSTRM{writer=PIO.WR{name, ...}, ...}, mlOp, exn) =
438 :     raise IO.Io{function=mlOp, name=name, cause=exn}
439 :    
440 :     fun isNL #"\n" = true
441 :     | isNL _ = false
442 :    
443 :     fun isClosedOut (strm as OSTRM{closed=ref true, ...}, mlOp) =
444 :     outputExn (strm, mlOp, IO.ClosedStream)
445 :     | isClosedOut _ = ()
446 :    
447 :     fun flushBuffer (strm as OSTRM{buf, pos, writeArr, ...}, mlOp) = (
448 :     case !pos
449 :     of 0 => ()
450 :     | n => ((
451 :     writeArr {buf=buf, i=0, sz=SOME n}; pos := 0)
452 :     handle ex => outputExn (strm, mlOp, ex))
453 :     (* end case *))
454 :    
455 :     (* A version of copyVec that checks for newlines, while it is copying.
456 :     * This is used for LINE_BUF output of strings and substrings.
457 :     *)
458 :     fun lineBufCopyVec (src, srcI, srcLen, dst, dstI) = let
459 :     val stop = srcI+srcLen
460 :     fun cpy (srcI, dstI, lb) =
461 :     if (srcI < stop)
462 :     then let val c = vecSub(src, srcI)
463 :     in
464 :     arrUpdate (dst, dstI, c);
465 :     cpy (srcI+1, dstI+1, lb orelse isNL c)
466 :     end
467 :     else lb
468 :     in
469 :     cpy (srcI, dstI, false)
470 :     end
471 :    
472 :     (* a version of copyVec for BLOCK_BUF output of strings and substrings. *)
473 :     fun blockBufCopyVec (src, srcI, srcLen, dst, dstI) = (
474 :     A.copyVec {
475 :     src = src, si = srcI, len = SOME srcLen, dst = dst, di = dstI
476 :     };
477 :     false)
478 :    
479 :     fun output (strm as OSTRM os, v) = let
480 :     val _ = isClosedOut (strm, "output")
481 :     val {buf, pos, bufferMode, ...} = os
482 :     fun flush () = flushBuffer (strm, "output")
483 :     fun writeDirect () = (
484 :     case !pos
485 :     of 0 => ()
486 :     | n => (#writeArr os {buf=buf, i=0, sz=SOME n}; pos := 0)
487 :     (* end case *);
488 :     #writeVec os {buf=v, i=0, sz=NONE})
489 :     handle ex => outputExn (strm, "output", ex)
490 :     fun insert copyVec = let
491 :     val bufLen = A.length buf
492 :     val dataLen = V.length v
493 :     in
494 :     if (dataLen >= bufLen)
495 :     then writeDirect()
496 :     else let
497 :     val i = !pos
498 :     val avail = bufLen - i
499 :     in
500 :     if (avail < dataLen)
501 :     then let
502 :     val _ = A.copyVec{
503 :     src=v, si=0, len=SOME avail, dst=buf, di=i
504 :     }
505 :     val _ = #writeArr os {buf=buf, i=0, sz=NONE}
506 :     handle ex => (
507 :     pos := bufLen;
508 :     outputExn (strm, "output", ex))
509 :     val needsFlush = copyVec(v, avail, dataLen-avail, buf, 0)
510 :     in
511 :     pos := dataLen-avail;
512 :     if needsFlush then flush() else ()
513 :     end
514 :     else let
515 :     val needsFlush = copyVec(v, 0, dataLen, buf, i)
516 :     in
517 :     pos := i + dataLen;
518 :     if (needsFlush orelse (avail = dataLen))
519 :     then flush()
520 :     else ()
521 :     end
522 :     end
523 :     end
524 :     in
525 :     case !bufferMode
526 :     of IO.NO_BUF => writeDirect ()
527 :     | IO.LINE_BUF => insert lineBufCopyVec
528 :     | IO.BLOCK_BUF => insert blockBufCopyVec
529 :     (* end case *)
530 :     end
531 :    
532 :     fun output1 (strm as OSTRM{buf, pos, bufferMode, writeArr, ...}, elem) = (
533 :     isClosedOut (strm, "output1");
534 :     case !bufferMode
535 :     of IO.NO_BUF => (
536 :     arrUpdate (buf, 0, elem);
537 :     writeArr {buf=buf, i=0, sz=SOME 1}
538 :     handle ex => outputExn (strm, "output1", ex))
539 :     | IO.LINE_BUF => let val i = !pos val i' = i+1
540 :     in
541 :     arrUpdate (buf, i, elem); pos := i';
542 :     if ((i' = A.length buf) orelse (isNL elem))
543 :     then flushBuffer (strm, "output1")
544 :     else ()
545 :     end
546 :     | IO.BLOCK_BUF => let val i = !pos val i' = i+1
547 :     in
548 :     arrUpdate (buf, i, elem); pos := i';
549 :     if (i' = A.length buf)
550 :     then flushBuffer (strm, "output1")
551 :     else ()
552 :     end
553 :     (* end case *))
554 :    
555 :     fun flushOut strm = (
556 :     flushBuffer (strm, "flushOut"))
557 :    
558 :     fun closeOut (strm as OSTRM{writer=PIO.WR{close, ...}, closed, cleanTag, ...}) =
559 :     if !closed
560 :     then ()
561 :     else (
562 :     flushBuffer (strm, "closeOut");
563 :     closed := true;
564 :     CleanIO.removeCleaner cleanTag;
565 :     close())
566 :    
567 :     fun mkOutstream (wr as PIO.WR{chunkSize, writeArr, writeVec, ...}, mode) =
568 :     let
569 :     fun iterate f (buf, i, sz) = let
570 :     fun lp (_, 0) = ()
571 :     | lp (i, n) = let val n' = f{buf=buf, i=i, sz=SOME n}
572 :     in lp (i+n', n-n') end
573 :     in
574 :     lp (i, sz)
575 :     end
576 :     val writeArr' = (case writeArr
577 :     of NONE => (fn _ => raise IO.BlockingNotSupported)
578 :     | (SOME f) => let
579 :     fun write {buf, i, sz} = let
580 :     val len = (case sz
581 :     of NONE => A.length buf - i
582 :     | (SOME n) => n
583 :     (* end case *))
584 :     in
585 :     iterate f (buf, i, len)
586 :     end
587 :     in
588 :     write
589 :     end
590 :     (* end case *))
591 :     val writeVec' = (case writeVec
592 :     of NONE => (fn _ => raise IO.BlockingNotSupported)
593 :     | (SOME f) => let
594 :     fun write {buf, i, sz} = let
595 :     val len = (case sz
596 :     of NONE => V.length buf - i
597 :     | (SOME n) => n
598 :     (* end case *))
599 :     in
600 :     iterate f (buf, i, len)
601 :     end
602 :     in
603 :     write
604 :     end
605 :     (* end case *))
606 :     (* install a dummy cleaner *)
607 :     val tag = CleanIO.addCleaner {
608 :     init = fn () => (),
609 :     flush = fn () => (),
610 :     close = fn () => ()
611 :     }
612 :     val strm = OSTRM{
613 :     buf = A.array(chunkSize, someElem),
614 :     pos = ref 0,
615 :     closed = ref false,
616 :     bufferMode = ref mode,
617 :     writer = wr,
618 :     writeArr = writeArr',
619 :     writeVec = writeVec',
620 :     cleanTag = tag
621 :     }
622 :     in
623 :     CleanIO.rebindCleaner (tag, {
624 :     init = fn () => closeOut strm,
625 :     flush = fn () => flushOut strm,
626 :     close = fn () => closeOut strm
627 :     });
628 :     strm
629 :     end
630 :    
631 :     fun getWriter (strm as OSTRM{writer, bufferMode, ...}) = (
632 :     flushBuffer (strm, "getWriter");
633 :     (writer, !bufferMode))
634 :    
635 :     (** Position operations on outstreams **)
636 :     datatype out_pos = OUTP of {
637 :     pos : PIO.pos,
638 :     strm : outstream
639 :     }
640 :    
641 :     fun getPosOut (strm as OSTRM{writer, ...}) = (
642 :     flushBuffer (strm, "getPosOut");
643 :     case writer
644 :     of PIO.WR{getPos=SOME f, ...} => (
645 :     OUTP{pos = f(), strm = strm}
646 :     handle ex => outputExn(strm, "getPosOut", ex))
647 :     | _ => outputExn(strm, "getPosOut", IO.RandomAccessNotSupported)
648 :     (* end case *))
649 :     fun filePosOut (OUTP{pos, strm}) = (
650 :     isClosedOut (strm, "filePosOut"); pos)
651 :     fun setPosOut (OUTP{pos, strm as OSTRM{writer, ...}}) = (
652 :     isClosedOut (strm, "setPosOut");
653 :     case writer
654 :     of PIO.WR{setPos=SOME f, ...} => (
655 :     (f pos)
656 :     handle ex => outputExn(strm, "setPosOut", ex))
657 :     | _ => outputExn(strm, "getPosOut", IO.RandomAccessNotSupported)
658 :     (* end case *))
659 :    
660 :     (** Text stream specific operations **)
661 :     fun outputSubstr (strm as OSTRM os, ss) = let
662 :     val _ = isClosedOut (strm, "outputSubstr")
663 :     val (v, dataStart, dataLen) = substringBase ss
664 :     val {buf, pos, bufferMode, ...} = os
665 :     val bufLen = A.length buf
666 :     fun flush () = flushBuffer (strm, "outputSubstr")
667 :     fun writeDirect () = (
668 :     case !pos
669 :     of 0 => ()
670 :     | n => (#writeArr os {buf=buf, i=0, sz=SOME n}; pos := 0)
671 :     (* end case *);
672 :     #writeVec os {buf=v, i=dataStart, sz=SOME dataLen})
673 :     handle ex => outputExn (strm, "outputSubstr", ex)
674 :     fun insert copyVec = let
675 :     val bufLen = A.length buf
676 :     in
677 :     if (dataLen >= bufLen)
678 :     then writeDirect()
679 :     else let
680 :     val i = !pos
681 :     val avail = bufLen - i
682 :     in
683 :     if (avail < dataLen)
684 :     then let
685 :     val _ = A.copyVec{
686 :     src=v, si=dataStart, len=SOME avail, dst=buf, di=i
687 :     }
688 :     val _ = #writeArr os {buf=buf, i=0, sz=NONE}
689 :     handle ex => (
690 :     pos := bufLen;
691 :     outputExn (strm, "outputSubstr", ex))
692 :     val needsFlush = copyVec(v, avail, dataLen-avail, buf, 0)
693 :     in
694 :     pos := dataLen-avail;
695 :     if needsFlush then flush() else ()
696 :     end
697 :     else let
698 :     val needsFlush = copyVec(v, dataStart, dataLen, buf, i)
699 :     in
700 :     pos := i + dataLen;
701 :     if (needsFlush orelse (avail = dataLen))
702 :     then flush()
703 :     else ()
704 :     end
705 :     end
706 :     end
707 :     in
708 :     case !bufferMode
709 :     of IO.NO_BUF => writeDirect()
710 :     | IO.LINE_BUF => insert lineBufCopyVec
711 :     | IO.BLOCK_BUF => insert blockBufCopyVec
712 :     (* end case *)
713 :     end
714 :    
715 :     fun setBufferMode (strm as OSTRM{bufferMode, ...}, IO.NO_BUF) = (
716 :     flushBuffer (strm, "setBufferMode");
717 :     bufferMode := IO.NO_BUF)
718 :     | setBufferMode (strm as OSTRM{bufferMode, ...}, mode) = (
719 :     isClosedOut (strm, "setBufferMode");
720 :     bufferMode := mode)
721 :     fun getBufferMode (strm as OSTRM{bufferMode, ...}) = (
722 :     isClosedOut (strm, "getBufferMode");
723 :     !bufferMode)
724 :    
725 :     end (* StreamIO *)
726 :    
727 :     type vector = V.vector
728 :     type elem = V.elem
729 :     type instream = StreamIO.instream ref
730 :     type outstream = StreamIO.outstream ref
731 :    
732 :     (** Input operations **)
733 :     fun input strm = let val (v, strm') = StreamIO.input(!strm)
734 :     in
735 :     strm := strm'; v
736 :     end
737 :     fun input1 strm = (case StreamIO.input1(!strm)
738 :     of NONE => NONE
739 :     | (SOME(elem, strm')) => (strm := strm'; SOME elem)
740 :     (* end case *))
741 :     fun inputN (strm, n) = let val (v, strm') = StreamIO.inputN (!strm, n)
742 :     in
743 :     strm := strm'; v
744 :     end
745 :     fun inputAll (strm : instream) = let
746 : monnier 143 val (s as StreamIO.ISTRM(buf, _)) = !strm
747 :     val v = StreamIO.inputAll s
748 : monnier 16 in
749 : monnier 143 strm := StreamIO.findEOS buf; v
750 : monnier 16 end
751 :     fun canInput (strm, n) = StreamIO.canInput (!strm, n)
752 :     fun lookahead (strm : instream) = (case StreamIO.input1(!strm)
753 :     of NONE => NONE
754 :     | (SOME(elem, _)) => SOME elem
755 :     (* end case *))
756 :     fun closeIn strm = let
757 :     val (s as StreamIO.ISTRM(buf as StreamIO.IBUF{data, ...}, _)) = !strm
758 :     in
759 :     StreamIO.closeIn s;
760 :     strm := StreamIO.findEOS buf
761 :     end
762 :     fun endOfStream strm = StreamIO.endOfStream(! strm)
763 :     fun getPosIn strm = StreamIO.getPosIn(!strm)
764 :     fun setPosIn (strm, p) = (strm := StreamIO.setPosIn p)
765 :    
766 :     (** Output operations **)
767 :     fun output (strm, v) = StreamIO.output(!strm, v)
768 :     fun output1 (strm, c) = StreamIO.output1(!strm, c)
769 :     fun flushOut strm = StreamIO.flushOut(!strm)
770 :     fun closeOut strm = StreamIO.closeOut(!strm)
771 :     fun getPosOut strm = StreamIO.getPosOut(!strm)
772 :     fun setPosOut (strm, p as StreamIO.OUTP{strm=strm', ...}) = (
773 :     strm := strm'; StreamIO.setPosOut p)
774 :    
775 :     fun mkInstream (strm : StreamIO.instream) = ref strm
776 :     fun getInstream (strm : instream) = !strm
777 :     fun setInstream (strm : instream, strm') = strm := strm'
778 :    
779 :     fun mkOutstream (strm : StreamIO.outstream) = ref strm
780 :     fun getOutstream (strm : outstream) = !strm
781 :     fun setOutstream (strm : outstream, strm') = strm := strm'
782 :    
783 :     (* figure out the proper buffering mode for a given writer *)
784 :     fun bufferMode (PIO.WR{ioDesc=NONE, ...}) = IO.BLOCK_BUF
785 :     | bufferMode (PIO.WR{ioDesc=SOME iod, ...}) =
786 :     if (OS.IO.kind iod = OS.IO.Kind.tty) then IO.LINE_BUF else IO.BLOCK_BUF
787 :    
788 :     (** Open files **)
789 :     fun openIn fname =
790 : monnier 143 mkInstream(StreamIO.mkInstream(OSPrimIO.openRd fname, empty))
791 : monnier 16 handle ex => raise IO.Io{function="openIn", name=fname, cause=ex}
792 :     fun openOut fname = let
793 :     val wr = OSPrimIO.openWr fname
794 :     in
795 :     mkOutstream (StreamIO.mkOutstream (wr, bufferMode wr))
796 :     end
797 :     handle ex => raise IO.Io{function="openOut", name=fname, cause=ex}
798 :     fun openAppend fname =
799 :     mkOutstream(StreamIO.mkOutstream(OSPrimIO.openApp fname, IO.NO_BUF))
800 :     handle ex => raise IO.Io{function="openAppend", name=fname, cause=ex}
801 :    
802 :     (** Text stream specific operations **)
803 :     fun inputLine strm = let val (s, strm') = StreamIO.inputLine (!strm)
804 :     in
805 :     strm := strm'; s
806 :     end
807 :     fun outputSubstr (strm, ss) = StreamIO.outputSubstr (!strm, ss)
808 :     fun openString src =
809 : monnier 143 mkInstream(StreamIO.mkInstream(OSPrimIO.strReader src, empty))
810 : monnier 16 handle ex => raise IO.Io{function="openIn", name="<string>", cause=ex}
811 :    
812 :     (* the standard streams *)
813 :     local
814 :     structure SIO = StreamIO
815 :     fun mkStdIn () = let
816 :     val (strm as SIO.ISTRM(SIO.IBUF{info=SIO.INFO{cleanTag, ...}, ...}, _)) =
817 : monnier 143 SIO.mkInstream(OSPrimIO.stdIn(), empty)
818 : monnier 16 in
819 :     CleanIO.rebindCleaner (cleanTag, {
820 :     init = fn () => (),
821 :     flush = fn () => (),
822 :     close = fn () => ()
823 :     });
824 :     strm
825 :     end
826 :     fun mkStdOut () = let
827 :     val wr = OSPrimIO.stdOut()
828 :     val (strm as SIO.OSTRM{cleanTag, ...}) =
829 :     SIO.mkOutstream(wr, bufferMode wr)
830 :     in
831 :     CleanIO.rebindCleaner (cleanTag, {
832 :     init = fn () => (),
833 :     flush = fn () => SIO.flushOut strm,
834 :     close = fn () => SIO.flushOut strm
835 :     });
836 :     strm
837 :     end
838 :     fun mkStdErr () = let
839 :     val (strm as SIO.OSTRM{cleanTag, ...}) =
840 :     SIO.mkOutstream(OSPrimIO.stdErr(), IO.NO_BUF)
841 :     in
842 :     CleanIO.rebindCleaner (cleanTag, {
843 :     init = fn () => (),
844 :     flush = fn () => SIO.flushOut strm,
845 :     close = fn () => SIO.flushOut strm
846 :     });
847 :     strm
848 :     end
849 :     in
850 :     val stdIn = mkInstream(mkStdIn())
851 :     val stdOut = mkOutstream(mkStdOut())
852 :     val stdErr = mkOutstream(mkStdErr())
853 :    
854 :     (* Establish a hook function to rebuild the I/O stack *)
855 :     val _ = CleanIO.stdStrmHook := (fn () => (
856 :     setInstream (stdIn, mkStdIn());
857 :     setOutstream (stdOut, mkStdOut());
858 :     setOutstream (stdErr, mkStdErr())))
859 :     end (* local *)
860 :    
861 :     fun print s = (output (stdOut, s); flushOut stdOut)
862 :    
863 :     fun scanStream scanFn = let
864 :     val scan = scanFn StreamIO.input1
865 :     fun doit strm = let
866 :     val instrm = getInstream strm
867 :     in
868 :     case scan instrm
869 :     of NONE => NONE
870 :     | SOME(item, instrm') => (
871 :     setInstream(strm, instrm');
872 :     SOME item)
873 :     (* end case *)
874 :     end
875 :     in
876 :     doit
877 :     end
878 :    
879 :     end (* TextIOFn *)
880 :    
881 :     (*
882 : monnier 113 * $Log$
883 : monnier 16 *)

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