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/cml/src/IO/text-io-fn.sml
ViewVC logotype

Annotation of /sml/trunk/src/cml/src/IO/text-io-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 167 - (view) (download)
Original Path: sml/branches/SMLNJ/src/cml/src/IO/text-io-fn.sml

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

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