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 17 - (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 :     in
239 :     (data, findEOS buf)
240 :     end
241 :     (* Return SOME k, if k <= amount characters can be read without blocking. *)
242 :     fun canInput (strm as ISTRM(buf, pos), amount) = let
243 :     val readVecNB = (case buf
244 :     of (IBUF{info as INFO{readVecNB=NONE, ...}, ...}) =>
245 :     inputExn(info, "canInput", IO.NonblockingNotSupported)
246 :     | (IBUF{info=INFO{readVecNB=SOME f, ...}, ...}) => f
247 :     (* end case *))
248 :     fun tryInput (buf as IBUF{data, ...}, i, n) = let
249 :     val len = V.length data
250 :     val remain = len - i
251 :     in
252 :     if (remain >= n)
253 :     then SOME n
254 :     else nextBuf (buf, n - remain)
255 :     end
256 :     and nextBuf (IBUF{more, ...}, n) = (case !more
257 :     of (MORE buf) => tryInput (buf, 0, n)
258 :     | TERMINATED => SOME(amount - n)
259 :     | NOMORE => ((
260 :     case extendStream (readVecNB, "canInput", buf)
261 :     of EOF => SOME(amount - n)
262 :     | (DATA b) => tryInput (b, 0, n)
263 :     (* end case *))
264 :     handle IO.Io{cause=WouldBlock, ...} => SOME(amount - n))
265 :     (* end case *))
266 :     in
267 :     if (amount < 0)
268 :     then raise Size
269 :     else tryInput (buf, pos, amount)
270 :     end
271 :     fun closeIn (ISTRM(buf, _)) = (case (infoOfIBuf buf)
272 :     of INFO{closed=ref true, ...} => ()
273 :     | (info as INFO{closed, reader=PIO.RD{close, ...}, ...}) => (
274 :     terminate info;
275 :     closed := true;
276 :     close() handle ex => inputExn(info, "closeIn", ex))
277 :     (* end case *))
278 :     fun endOfStream (ISTRM(buf, pos)) = (case buf
279 :     of (IBUF{more=ref(MORE _), ...}) => false
280 :     | (IBUF{more, data, info=INFO{closed, ...}, ...}) =>
281 :     if (pos = V.length data)
282 :     then (case (!more, !closed)
283 :     of (NOMORE, false) => (
284 :     case extendStream (readVec buf, "endOfStream", buf)
285 :     of EOF => true
286 :     | _ => false
287 :     (* end case *))
288 :     | _ => true
289 :     (* end case *))
290 :     else false
291 :     (* end case *))
292 :     fun mkInstream (reader, optData) = let
293 :     val PIO.RD{readVec, readVecNB, getPos, setPos, ...} = reader
294 :     val readVec' = (case readVec
295 :     of NONE => (fn _ => raise IO.BlockingNotSupported)
296 :     | (SOME f) => f
297 :     (* end case *))
298 :     val readVecNB' = (case readVecNB
299 :     of NONE => NONE
300 :     | (SOME f) => SOME(fn arg => case (f arg)
301 :     of (SOME x) => x
302 :     | NONE => raise WouldBlock
303 :     (* end case *))
304 :     (* end case *))
305 :     val getPos = (case (getPos, setPos)
306 :     of (SOME f, SOME _) => (fn () => SOME(f()))
307 :     | _ => (fn () => NONE)
308 :     (* end case *))
309 :     val more = ref NOMORE
310 :     val closedFlg = ref false
311 :     val tag = CleanIO.addCleaner {
312 :     init = fn () => (closedFlg := true),
313 :     flush = fn () => (),
314 :     close = fn () => (closedFlg := true)
315 :     }
316 :     val info = INFO{
317 :     reader=reader, readVec=readVec', readVecNB=readVecNB',
318 :     closed = closedFlg, getPos = getPos, tail = ref more,
319 :     cleanTag = tag
320 :     }
321 :     val buf = (case optData
322 :     of NONE => IBUF{
323 :     basePos = getPos(), data=empty,
324 :     info=info, more=more
325 :     }
326 :     (** What should we do about the position in this case ?? **)
327 :     (** Suggestion: When building a stream with supplied initial data,
328 :     ** nothing can be said about the positions inside that initial
329 :     ** data (who knows where that data even came from!).
330 :     **)
331 :     | (SOME v) => IBUF{
332 :     basePos = NONE, data=v,
333 :     info=info, more=more}
334 :     (* end case *))
335 :     in
336 :     ISTRM(buf, 0)
337 :     end
338 :    
339 :     fun getReader (ISTRM(buf, pos)) = let
340 :     val IBUF{data, info as INFO{reader, ...}, more, ...} = buf
341 :     fun getData (MORE(IBUF{data, more, ...})) = data :: getData(!more)
342 :     | getData _ = []
343 :     in
344 :     terminate info;
345 :     if (pos < V.length data)
346 :     then (
347 :     reader,
348 :     V.concat(vecExtract(data, pos, NONE) :: getData(!more))
349 :     )
350 :     else (reader, V.concat(getData(!more)))
351 :     end
352 :    
353 :     (** Position operations on instreams **)
354 :     datatype in_pos = INP of {
355 :     base : pos,
356 :     offset : int,
357 :     info : info
358 :     }
359 :    
360 :     fun getPosIn (ISTRM(buf, pos)) = (case buf
361 :     of IBUF{basePos=NONE, info, ...} =>
362 :     inputExn (info, "getPosIn", IO.RandomAccessNotSupported)
363 :     | IBUF{basePos=SOME p, info, ...} => INP{
364 :     base = p, offset = pos, info = info
365 :     }
366 :     (* end case *))
367 :     fun filePosIn (INP{base, offset=0, ...}) = base
368 :     | filePosIn (INP{base, offset, info}) = let
369 :     val INFO{reader=PIO.RD rd, readVec, ...} = info
370 :     in
371 :     case (#getPos rd, #setPos rd)
372 :     of (SOME getPos, SOME setPos) => let
373 :     val tmpPos = getPos()
374 :     fun readN 0 = ()
375 :     | readN n = (case V.length(readVec n)
376 :     of 0 => inputExn (
377 :     info, "filePosIn", Fail "bogus position")
378 :     | k => readN(n-k)
379 :     (* end case *))
380 :     in
381 :     setPos base;
382 :     readN offset;
383 :     getPos () before setPos tmpPos
384 :     end
385 :     | _ => raise Fail "filePosIn: impossible"
386 :     (* end case *)
387 :     end
388 :     fun setPosIn (pos as INP{info as INFO{reader, ...}, ...}) = let
389 :     val fpos = filePosIn pos
390 :     val (PIO.RD rd) = reader
391 :     in
392 :     terminate info;
393 :     Option.valOf (#setPos rd) fpos;
394 :     mkInstream (PIO.RD rd, NONE)
395 :     end
396 :    
397 :     (** Text stream specific operations **)
398 :     fun inputLine (ISTRM(buf as IBUF{data, ...}, pos)) = let
399 :     fun join (item, (list, strm)) = (item::list, strm)
400 :     fun nextBuf (isEmpty, buf as IBUF{more, data, ...}) = let
401 :     fun last () =
402 :     (if isEmpty then [] else ["\n"], ISTRM(buf, V.length data))
403 :     in
404 :     case !more
405 :     of (MORE buf) => scanData (buf, 0)
406 :     | NOMORE => (
407 :     case extendStream (readVec buf, "inputLine", buf)
408 :     of EOF => last ()
409 :     | (DATA rest) => scanData (rest, 0)
410 :     (* end case *))
411 :     | TERMINATED => last ()
412 :     (* end case *)
413 :     end
414 :     and scanData (buf as IBUF{data, more, ...}, i) = let
415 :     val len = V.length data
416 :     fun scan j = if (j = len)
417 :     then join(vecExtract(data, i, NONE), nextBuf(false, buf))
418 :     else if (vecSub(data, j) = #"\n")
419 :     then ([vecExtract(data, i, SOME(j+1-i))], ISTRM(buf, j+1))
420 :     else scan (j+1)
421 :     in
422 :     scan i
423 :     end
424 :     val (data, strm) = if (V.length data = pos)
425 :     then nextBuf (true, buf)
426 :     else scanData (buf, pos)
427 :     in
428 :     (V.concat data, strm)
429 :     end
430 :    
431 :     (*** Output streams ***)
432 :     datatype outstream = OSTRM of {
433 :     buf : A.array,
434 :     pos : int ref,
435 :     closed : bool ref,
436 :     bufferMode : IO.buffer_mode ref,
437 :     writer : writer,
438 :     writeArr : {buf : A.array, i : int, sz : int option} -> unit,
439 :     writeVec : {buf : V.vector, i : int, sz : int option} -> unit,
440 :     cleanTag : CleanIO.tag
441 :     }
442 :    
443 :     fun outputExn (OSTRM{writer=PIO.WR{name, ...}, ...}, mlOp, exn) =
444 :     raise IO.Io{function=mlOp, name=name, cause=exn}
445 :    
446 :     fun isNL #"\n" = true
447 :     | isNL _ = false
448 :    
449 :     fun isClosedOut (strm as OSTRM{closed=ref true, ...}, mlOp) =
450 :     outputExn (strm, mlOp, IO.ClosedStream)
451 :     | isClosedOut _ = ()
452 :    
453 :     fun flushBuffer (strm as OSTRM{buf, pos, writeArr, ...}, mlOp) = (
454 :     case !pos
455 :     of 0 => ()
456 :     | n => ((
457 :     writeArr {buf=buf, i=0, sz=SOME n}; pos := 0)
458 :     handle ex => outputExn (strm, mlOp, ex))
459 :     (* end case *))
460 :    
461 :     (* A version of copyVec that checks for newlines, while it is copying.
462 :     * This is used for LINE_BUF output of strings and substrings.
463 :     *)
464 :     fun lineBufCopyVec (src, srcI, srcLen, dst, dstI) = let
465 :     val stop = srcI+srcLen
466 :     fun cpy (srcI, dstI, lb) =
467 :     if (srcI < stop)
468 :     then let val c = vecSub(src, srcI)
469 :     in
470 :     arrUpdate (dst, dstI, c);
471 :     cpy (srcI+1, dstI+1, lb orelse isNL c)
472 :     end
473 :     else lb
474 :     in
475 :     cpy (srcI, dstI, false)
476 :     end
477 :    
478 :     (* a version of copyVec for BLOCK_BUF output of strings and substrings. *)
479 :     fun blockBufCopyVec (src, srcI, srcLen, dst, dstI) = (
480 :     A.copyVec {
481 :     src = src, si = srcI, len = SOME srcLen, dst = dst, di = dstI
482 :     };
483 :     false)
484 :    
485 :     fun output (strm as OSTRM os, v) = let
486 :     val _ = isClosedOut (strm, "output")
487 :     val {buf, pos, bufferMode, ...} = os
488 :     fun flush () = flushBuffer (strm, "output")
489 :     fun writeDirect () = (
490 :     case !pos
491 :     of 0 => ()
492 :     | n => (#writeArr os {buf=buf, i=0, sz=SOME n}; pos := 0)
493 :     (* end case *);
494 :     #writeVec os {buf=v, i=0, sz=NONE})
495 :     handle ex => outputExn (strm, "output", ex)
496 :     fun insert copyVec = let
497 :     val bufLen = A.length buf
498 :     val dataLen = V.length v
499 :     in
500 :     if (dataLen >= bufLen)
501 :     then writeDirect()
502 :     else let
503 :     val i = !pos
504 :     val avail = bufLen - i
505 :     in
506 :     if (avail < dataLen)
507 :     then let
508 :     val _ = A.copyVec{
509 :     src=v, si=0, len=SOME avail, dst=buf, di=i
510 :     }
511 :     val _ = #writeArr os {buf=buf, i=0, sz=NONE}
512 :     handle ex => (
513 :     pos := bufLen;
514 :     outputExn (strm, "output", ex))
515 :     val needsFlush = copyVec(v, avail, dataLen-avail, buf, 0)
516 :     in
517 :     pos := dataLen-avail;
518 :     if needsFlush then flush() else ()
519 :     end
520 :     else let
521 :     val needsFlush = copyVec(v, 0, dataLen, buf, i)
522 :     in
523 :     pos := i + dataLen;
524 :     if (needsFlush orelse (avail = dataLen))
525 :     then flush()
526 :     else ()
527 :     end
528 :     end
529 :     end
530 :     in
531 :     case !bufferMode
532 :     of IO.NO_BUF => writeDirect ()
533 :     | IO.LINE_BUF => insert lineBufCopyVec
534 :     | IO.BLOCK_BUF => insert blockBufCopyVec
535 :     (* end case *)
536 :     end
537 :    
538 :     fun output1 (strm as OSTRM{buf, pos, bufferMode, writeArr, ...}, elem) = (
539 :     isClosedOut (strm, "output1");
540 :     case !bufferMode
541 :     of IO.NO_BUF => (
542 :     arrUpdate (buf, 0, elem);
543 :     writeArr {buf=buf, i=0, sz=SOME 1}
544 :     handle ex => outputExn (strm, "output1", ex))
545 :     | IO.LINE_BUF => let val i = !pos val i' = i+1
546 :     in
547 :     arrUpdate (buf, i, elem); pos := i';
548 :     if ((i' = A.length buf) orelse (isNL elem))
549 :     then flushBuffer (strm, "output1")
550 :     else ()
551 :     end
552 :     | IO.BLOCK_BUF => let val i = !pos val i' = i+1
553 :     in
554 :     arrUpdate (buf, i, elem); pos := i';
555 :     if (i' = A.length buf)
556 :     then flushBuffer (strm, "output1")
557 :     else ()
558 :     end
559 :     (* end case *))
560 :    
561 :     fun flushOut strm = (
562 :     flushBuffer (strm, "flushOut"))
563 :    
564 :     fun closeOut (strm as OSTRM{writer=PIO.WR{close, ...}, closed, cleanTag, ...}) =
565 :     if !closed
566 :     then ()
567 :     else (
568 :     flushBuffer (strm, "closeOut");
569 :     closed := true;
570 :     CleanIO.removeCleaner cleanTag;
571 :     close())
572 :    
573 :     fun mkOutstream (wr as PIO.WR{chunkSize, writeArr, writeVec, ...}, mode) =
574 :     let
575 :     fun iterate f (buf, i, sz) = let
576 :     fun lp (_, 0) = ()
577 :     | lp (i, n) = let val n' = f{buf=buf, i=i, sz=SOME n}
578 :     in lp (i+n', n-n') end
579 :     in
580 :     lp (i, sz)
581 :     end
582 :     val writeArr' = (case writeArr
583 :     of NONE => (fn _ => raise IO.BlockingNotSupported)
584 :     | (SOME f) => let
585 :     fun write {buf, i, sz} = let
586 :     val len = (case sz
587 :     of NONE => A.length buf - i
588 :     | (SOME n) => n
589 :     (* end case *))
590 :     in
591 :     iterate f (buf, i, len)
592 :     end
593 :     in
594 :     write
595 :     end
596 :     (* end case *))
597 :     val writeVec' = (case writeVec
598 :     of NONE => (fn _ => raise IO.BlockingNotSupported)
599 :     | (SOME f) => let
600 :     fun write {buf, i, sz} = let
601 :     val len = (case sz
602 :     of NONE => V.length buf - i
603 :     | (SOME n) => n
604 :     (* end case *))
605 :     in
606 :     iterate f (buf, i, len)
607 :     end
608 :     in
609 :     write
610 :     end
611 :     (* end case *))
612 :     (* install a dummy cleaner *)
613 :     val tag = CleanIO.addCleaner {
614 :     init = fn () => (),
615 :     flush = fn () => (),
616 :     close = fn () => ()
617 :     }
618 :     val strm = OSTRM{
619 :     buf = A.array(chunkSize, someElem),
620 :     pos = ref 0,
621 :     closed = ref false,
622 :     bufferMode = ref mode,
623 :     writer = wr,
624 :     writeArr = writeArr',
625 :     writeVec = writeVec',
626 :     cleanTag = tag
627 :     }
628 :     in
629 :     CleanIO.rebindCleaner (tag, {
630 :     init = fn () => closeOut strm,
631 :     flush = fn () => flushOut strm,
632 :     close = fn () => closeOut strm
633 :     });
634 :     strm
635 :     end
636 :    
637 :     fun getWriter (strm as OSTRM{writer, bufferMode, ...}) = (
638 :     flushBuffer (strm, "getWriter");
639 :     (writer, !bufferMode))
640 :    
641 :     (** Position operations on outstreams **)
642 :     datatype out_pos = OUTP of {
643 :     pos : PIO.pos,
644 :     strm : outstream
645 :     }
646 :    
647 :     fun getPosOut (strm as OSTRM{writer, ...}) = (
648 :     flushBuffer (strm, "getPosOut");
649 :     case writer
650 :     of PIO.WR{getPos=SOME f, ...} => (
651 :     OUTP{pos = f(), strm = strm}
652 :     handle ex => outputExn(strm, "getPosOut", ex))
653 :     | _ => outputExn(strm, "getPosOut", IO.RandomAccessNotSupported)
654 :     (* end case *))
655 :     fun filePosOut (OUTP{pos, strm}) = (
656 :     isClosedOut (strm, "filePosOut"); pos)
657 :     fun setPosOut (OUTP{pos, strm as OSTRM{writer, ...}}) = (
658 :     isClosedOut (strm, "setPosOut");
659 :     case writer
660 :     of PIO.WR{setPos=SOME f, ...} => (
661 :     (f pos)
662 :     handle ex => outputExn(strm, "setPosOut", ex))
663 :     | _ => outputExn(strm, "getPosOut", IO.RandomAccessNotSupported)
664 :     (* end case *))
665 :    
666 :     (** Text stream specific operations **)
667 :     fun outputSubstr (strm as OSTRM os, ss) = let
668 :     val _ = isClosedOut (strm, "outputSubstr")
669 :     val (v, dataStart, dataLen) = substringBase ss
670 :     val {buf, pos, bufferMode, ...} = os
671 :     val bufLen = A.length buf
672 :     fun flush () = flushBuffer (strm, "outputSubstr")
673 :     fun writeDirect () = (
674 :     case !pos
675 :     of 0 => ()
676 :     | n => (#writeArr os {buf=buf, i=0, sz=SOME n}; pos := 0)
677 :     (* end case *);
678 :     #writeVec os {buf=v, i=dataStart, sz=SOME dataLen})
679 :     handle ex => outputExn (strm, "outputSubstr", ex)
680 :     fun insert copyVec = let
681 :     val bufLen = A.length buf
682 :     in
683 :     if (dataLen >= bufLen)
684 :     then writeDirect()
685 :     else let
686 :     val i = !pos
687 :     val avail = bufLen - i
688 :     in
689 :     if (avail < dataLen)
690 :     then let
691 :     val _ = A.copyVec{
692 :     src=v, si=dataStart, len=SOME avail, dst=buf, di=i
693 :     }
694 :     val _ = #writeArr os {buf=buf, i=0, sz=NONE}
695 :     handle ex => (
696 :     pos := bufLen;
697 :     outputExn (strm, "outputSubstr", ex))
698 :     val needsFlush = copyVec(v, avail, dataLen-avail, buf, 0)
699 :     in
700 :     pos := dataLen-avail;
701 :     if needsFlush then flush() else ()
702 :     end
703 :     else let
704 :     val needsFlush = copyVec(v, dataStart, dataLen, buf, i)
705 :     in
706 :     pos := i + dataLen;
707 :     if (needsFlush orelse (avail = dataLen))
708 :     then flush()
709 :     else ()
710 :     end
711 :     end
712 :     end
713 :     in
714 :     case !bufferMode
715 :     of IO.NO_BUF => writeDirect()
716 :     | IO.LINE_BUF => insert lineBufCopyVec
717 :     | IO.BLOCK_BUF => insert blockBufCopyVec
718 :     (* end case *)
719 :     end
720 :    
721 :     fun setBufferMode (strm as OSTRM{bufferMode, ...}, IO.NO_BUF) = (
722 :     flushBuffer (strm, "setBufferMode");
723 :     bufferMode := IO.NO_BUF)
724 :     | setBufferMode (strm as OSTRM{bufferMode, ...}, mode) = (
725 :     isClosedOut (strm, "setBufferMode");
726 :     bufferMode := mode)
727 :     fun getBufferMode (strm as OSTRM{bufferMode, ...}) = (
728 :     isClosedOut (strm, "getBufferMode");
729 :     !bufferMode)
730 :    
731 :     end (* StreamIO *)
732 :    
733 :     type vector = V.vector
734 :     type elem = V.elem
735 :     type instream = StreamIO.instream ref
736 :     type outstream = StreamIO.outstream ref
737 :    
738 :     (** Input operations **)
739 :     fun input strm = let val (v, strm') = StreamIO.input(!strm)
740 :     in
741 :     strm := strm'; v
742 :     end
743 :     fun input1 strm = (case StreamIO.input1(!strm)
744 :     of NONE => NONE
745 :     | (SOME(elem, strm')) => (strm := strm'; SOME elem)
746 :     (* end case *))
747 :     fun inputN (strm, n) = let val (v, strm') = StreamIO.inputN (!strm, n)
748 :     in
749 :     strm := strm'; v
750 :     end
751 :     fun inputAll (strm : instream) = let
752 :     val (v, strm') = StreamIO.inputAll(!strm)
753 :     in
754 :     strm := strm'; v
755 :     end
756 :     fun canInput (strm, n) = StreamIO.canInput (!strm, n)
757 :     fun lookahead (strm : instream) = (case StreamIO.input1(!strm)
758 :     of NONE => NONE
759 :     | (SOME(elem, _)) => SOME elem
760 :     (* end case *))
761 :     fun closeIn strm = let
762 :     val (s as StreamIO.ISTRM(buf as StreamIO.IBUF{data, ...}, _)) = !strm
763 :     in
764 :     StreamIO.closeIn s;
765 :     strm := StreamIO.findEOS buf
766 :     end
767 :     fun endOfStream strm = StreamIO.endOfStream(! strm)
768 :     fun getPosIn strm = StreamIO.getPosIn(!strm)
769 :     fun setPosIn (strm, p) = (strm := StreamIO.setPosIn p)
770 :    
771 :     (** Output operations **)
772 :     fun output (strm, v) = StreamIO.output(!strm, v)
773 :     fun output1 (strm, c) = StreamIO.output1(!strm, c)
774 :     fun flushOut strm = StreamIO.flushOut(!strm)
775 :     fun closeOut strm = StreamIO.closeOut(!strm)
776 :     fun getPosOut strm = StreamIO.getPosOut(!strm)
777 :     fun setPosOut (strm, p as StreamIO.OUTP{strm=strm', ...}) = (
778 :     strm := strm'; StreamIO.setPosOut p)
779 :    
780 :     fun mkInstream (strm : StreamIO.instream) = ref strm
781 :     fun getInstream (strm : instream) = !strm
782 :     fun setInstream (strm : instream, strm') = strm := strm'
783 :    
784 :     fun mkOutstream (strm : StreamIO.outstream) = ref strm
785 :     fun getOutstream (strm : outstream) = !strm
786 :     fun setOutstream (strm : outstream, strm') = strm := strm'
787 :    
788 :     (* figure out the proper buffering mode for a given writer *)
789 :     fun bufferMode (PIO.WR{ioDesc=NONE, ...}) = IO.BLOCK_BUF
790 :     | bufferMode (PIO.WR{ioDesc=SOME iod, ...}) =
791 :     if (OS.IO.kind iod = OS.IO.Kind.tty) then IO.LINE_BUF else IO.BLOCK_BUF
792 :    
793 :     (** Open files **)
794 :     fun openIn fname =
795 :     mkInstream(StreamIO.mkInstream(OSPrimIO.openRd fname, NONE))
796 :     handle ex => raise IO.Io{function="openIn", name=fname, cause=ex}
797 :     fun openOut fname = let
798 :     val wr = OSPrimIO.openWr fname
799 :     in
800 :     mkOutstream (StreamIO.mkOutstream (wr, bufferMode wr))
801 :     end
802 :     handle ex => raise IO.Io{function="openOut", name=fname, cause=ex}
803 :     fun openAppend fname =
804 :     mkOutstream(StreamIO.mkOutstream(OSPrimIO.openApp fname, IO.NO_BUF))
805 :     handle ex => raise IO.Io{function="openAppend", name=fname, cause=ex}
806 :    
807 :     (** Text stream specific operations **)
808 :     fun inputLine strm = let val (s, strm') = StreamIO.inputLine (!strm)
809 :     in
810 :     strm := strm'; s
811 :     end
812 :     fun outputSubstr (strm, ss) = StreamIO.outputSubstr (!strm, ss)
813 :     fun openString src =
814 :     mkInstream(StreamIO.mkInstream(OSPrimIO.strReader src, NONE))
815 :     handle ex => raise IO.Io{function="openIn", name="<string>", cause=ex}
816 :    
817 :     (* the standard streams *)
818 :     local
819 :     structure SIO = StreamIO
820 :     fun mkStdIn () = let
821 :     val (strm as SIO.ISTRM(SIO.IBUF{info=SIO.INFO{cleanTag, ...}, ...}, _)) =
822 :     SIO.mkInstream(OSPrimIO.stdIn(), NONE)
823 :     in
824 :     CleanIO.rebindCleaner (cleanTag, {
825 :     init = fn () => (),
826 :     flush = fn () => (),
827 :     close = fn () => ()
828 :     });
829 :     strm
830 :     end
831 :     fun mkStdOut () = let
832 :     val wr = OSPrimIO.stdOut()
833 :     val (strm as SIO.OSTRM{cleanTag, ...}) =
834 :     SIO.mkOutstream(wr, bufferMode wr)
835 :     in
836 :     CleanIO.rebindCleaner (cleanTag, {
837 :     init = fn () => (),
838 :     flush = fn () => SIO.flushOut strm,
839 :     close = fn () => SIO.flushOut strm
840 :     });
841 :     strm
842 :     end
843 :     fun mkStdErr () = let
844 :     val (strm as SIO.OSTRM{cleanTag, ...}) =
845 :     SIO.mkOutstream(OSPrimIO.stdErr(), IO.NO_BUF)
846 :     in
847 :     CleanIO.rebindCleaner (cleanTag, {
848 :     init = fn () => (),
849 :     flush = fn () => SIO.flushOut strm,
850 :     close = fn () => SIO.flushOut strm
851 :     });
852 :     strm
853 :     end
854 :     in
855 :     val stdIn = mkInstream(mkStdIn())
856 :     val stdOut = mkOutstream(mkStdOut())
857 :     val stdErr = mkOutstream(mkStdErr())
858 :    
859 :     (* Establish a hook function to rebuild the I/O stack *)
860 :     val _ = CleanIO.stdStrmHook := (fn () => (
861 :     setInstream (stdIn, mkStdIn());
862 :     setOutstream (stdOut, mkStdOut());
863 :     setOutstream (stdErr, mkStdErr())))
864 :     end (* local *)
865 :    
866 :     fun print s = (output (stdOut, s); flushOut stdOut)
867 :    
868 :     fun scanStream scanFn = let
869 :     val scan = scanFn StreamIO.input1
870 :     fun doit strm = let
871 :     val instrm = getInstream strm
872 :     in
873 :     case scan instrm
874 :     of NONE => NONE
875 :     | SOME(item, instrm') => (
876 :     setInstream(strm, instrm');
877 :     SOME item)
878 :     (* end case *)
879 :     end
880 :     in
881 :     doit
882 :     end
883 :    
884 :     end (* TextIOFn *)
885 :    
886 :     (*
887 :     * $Log: text-io-fn.sml,v $
888 :     * Revision 1.10 1997/11/18 17:19:44 jhr
889 :     * Added missing scanStream function.
890 :     *
891 :     * Revision 1.9 1997/10/01 14:52:22 jhr
892 :     * Minor code clean-up.
893 :     *
894 :     * Revision 1.8 1997/07/28 21:08:31 jhr
895 :     * ???
896 :     *
897 :     * Revision 1.7 1997/07/24 17:44:21 jhr
898 :     * Fixed bug with outputSubstr not handling line buffering properly (bug 1236).
899 :     *
900 :     * Revision 1.6 1997/07/15 15:53:23 dbm
901 :     * Change in where structure syntax.
902 :     *
903 :     * Revision 1.5 1997/05/20 12:13:25 dbm
904 :     * SML '97 sharing, where structure.
905 :     *
906 :     * Revision 1.4 1997/02/26 21:00:26 george
907 :     * Defined a new top level Option structure. All 'a option related
908 :     * functions have been moved out of General.
909 :     *
910 :     * Revision 1.3 1997/02/18 14:18:29 george
911 :     * Fixed bug related to random access (John).
912 :     *
913 :     * Revision 1.2 1997/01/28 23:12:48 jhr
914 :     * Fixed bug in canInput, where an exception could escape.
915 :     *
916 :     * Revision 1.1.1.1 1997/01/14 01:38:19 george
917 :     * Version 109.24
918 :     *
919 :     *)

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