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 3 - (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 :     (* note that we do not fill the newMore cell until
111 :     * 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 :     fun mkInstream (reader, optData) = let
335 :     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 :     val buf = (case optData
349 :     of NONE => IBUF{
350 :     basePos = getPos(), data=empty,
351 :     info=info, more=more
352 :     }
353 :     (** What should we do about the position in this case ?? **)
354 :     (** Suggestion: When building a stream with supplied initial data,
355 :     ** nothing can be said about the positions inside that initial
356 :     ** data (who knows where that data even came from!).
357 :     **)
358 :     | (SOME v) => IBUF{
359 :     basePos = NONE, data=v,
360 :     info=info, more=more}
361 :     (* end case *))
362 :     val strm = ISTRM(buf, 0)
363 :     in
364 :     CleanIO.rebindCleaner (tag, fn () => closeIn strm);
365 :     strm
366 :     end
367 :     fun getReader (ISTRM(buf, pos)) = let
368 :     val IBUF{data, info as INFO{reader, ...}, more, ...} = buf
369 :     fun getData more = (case SV.mGet more
370 :     of (MORE(IBUF{data, more=more', ...})) => data :: getData more'
371 :     | _ => []
372 :     (* end case *))
373 :     in
374 :     terminate info;
375 :     if (pos < V.length data)
376 :     then (
377 :     reader,
378 :     V.concat(vecExtract(data, pos, NONE) :: getData more)
379 :     )
380 :     else (reader, V.concat(getData more))
381 :     end
382 :    
383 :     (** Position operations on instreams **)
384 :     datatype in_pos = INP of {
385 :     base : pos,
386 :     offset : int,
387 :     info : info
388 :     }
389 :    
390 :     fun getPosIn (ISTRM(buf, pos)) = (case buf
391 :     of IBUF{basePos=NONE, info, ...} =>
392 :     inputExn (info, "getPosIn", IO.RandomAccessNotSupported)
393 :     | IBUF{basePos=SOME p, info, ...} => INP{
394 :     base = p, offset = pos, info = info
395 :     }
396 :     (* end case *))
397 :     fun filePosIn (INP{base, offset, ...}) =
398 :     Position.+(base, Position.fromInt offset)
399 :     fun setPosIn (pos as INP{info as INFO{reader, ...}, ...}) = let
400 :     val fpos = filePosIn pos
401 :     val (PIO.RD rd) = reader
402 :     in
403 :     terminate info;
404 :     valOf (#setPos rd) fpos;
405 :     mkInstream (PIO.RD rd, NONE)
406 :     end
407 :    
408 :     (** Text stream specific operations **)
409 :     fun inputLine (ISTRM(buf as IBUF{data, ...}, pos)) = let
410 :     fun join (item, (list, strm)) = (item::list, strm)
411 :     fun nextBuf (isEmpty, buf as IBUF{more, data, ...}) = let
412 :     fun last () =
413 :     (if isEmpty then [] else ["\n"], ISTRM(buf, V.length data))
414 :     fun get (MORE buf) = scanData (buf, 0)
415 :     | get NOMORE = (case (SV.mTake more)
416 :     of NOMORE => (
417 :     case extendStream (readVec buf, "inputLine", buf)
418 :     of EOF => last ()
419 :     | (DATA rest) => scanData (rest, 0)
420 :     (* end case *))
421 :     | next => (SV.mPut(more, next); get next)
422 :     (* end case *))
423 :     | get TERMINATED = last()
424 :     in
425 :     get (SV.mGet more)
426 :     end
427 :     and scanData (buf as IBUF{data, ...}, i) = let
428 :     val len = V.length data
429 :     fun scan j = if (j = len)
430 :     then join(vecExtract(data, i, NONE), nextBuf(false, buf))
431 :     else if (vecSub(data, j) = #"\n")
432 :     then ([vecExtract(data, i, SOME(j+1-i))], ISTRM(buf, j+1))
433 :     else scan (j+1)
434 :     in
435 :     scan i
436 :     end
437 :     val (data, strm) = if (V.length data = pos)
438 :     then nextBuf (true, buf)
439 :     else scanData (buf, pos)
440 :     in
441 :     (V.concat data, strm)
442 :     end
443 :    
444 :     (*** Output streams ***)
445 :    
446 :     (* an output stream is implemented as a monitor using an mvar to
447 :     * hold its data.
448 :     *)
449 :     datatype ostrm_info = OSTRM of {
450 :     buf : A.array,
451 :     pos : int ref,
452 :     closed : bool ref,
453 :     bufferMode : IO.buffer_mode ref,
454 :     writer : writer,
455 :     writeArr : {buf : A.array, i : int, sz : int option} -> unit,
456 :     writeVec : {buf : V.vector, i : int, sz : int option} -> unit,
457 :     cleanTag : CleanIO.tag
458 :     }
459 :    
460 :     type outstream = ostrm_info SV.mvar
461 :    
462 :     fun isNL #"\n" = true
463 :     | isNL _ = false
464 :    
465 :     fun isLineBreak (OSTRM{bufferMode, ...}) =
466 :     if (!bufferMode = IO.LINE_BUF) then isNL else (fn _ => false)
467 :    
468 :     fun outputExn (OSTRM{writer=PIO.WR{name, ...}, ...}, mlOp, exn) =
469 :     raise IO.Io{function=mlOp, name=name, cause=exn}
470 :    
471 :     (* lock access to the stream and make sure that it is not closed. *)
472 :     fun lockAndChkClosedOut (strmMV, mlOp) = (case SV.mTake strmMV
473 :     of (strm as OSTRM({closed=ref true, ...})) => (
474 :     SV.mPut (strmMV, strm);
475 :     outputExn (strm, mlOp, IO.ClosedStream))
476 :     | strm => strm
477 :     (* end case *))
478 :    
479 :     fun flushBuffer (strmMV, strm as OSTRM{buf, pos, writeArr, ...}, mlOp) = (
480 :     case !pos
481 :     of 0 => ()
482 :     | n => ((
483 :     writeArr {buf=buf, i=0, sz=SOME n}; pos := 0)
484 :     handle ex => (
485 :     SV.mPut(strmMV, strm); outputExn (strm, mlOp, ex)))
486 :     (* end case *))
487 :    
488 :     (* A version of copyVec that checks for newlines, while it is copying.
489 :     * This is used for LINE_BUF output of strings and substrings.
490 :     *)
491 :     fun lineBufCopyVec (src, srcI, srcLen, dst, dstI) = let
492 :     val stop = srcI+srcLen
493 :     fun cpy (srcI, dstI, lb) =
494 :     if (srcI < stop)
495 :     then let val c = vecSub(src, srcI)
496 :     in
497 :     arrUpdate (dst, dstI, c);
498 :     cpy (srcI+1, dstI+1, lb orelse isNL c)
499 :     end
500 :     else lb
501 :     in
502 :     cpy (srcI, dstI, false)
503 :     end
504 :    
505 :     (* a version of copyVec for BLOCK_BUF output of strings and substrings. *)
506 :     fun blockBufCopyVec (src, srcI, srcLen, dst, dstI) = (
507 :     A.copyVec {
508 :     src = src, si = srcI, len = SOME srcLen, dst = dst, di = dstI
509 :     };
510 :     false)
511 :    
512 :     fun output (strmMV, v) = let
513 :     val (strm as OSTRM os) = lockAndChkClosedOut (strmMV, "output")
514 :     fun release () = SV.mPut (strmMV, strm)
515 :     val {buf, pos, bufferMode, ...} = os
516 :     fun flush () = flushBuffer (strmMV, strm, "output")
517 :     fun flushAll () = (#writeArr os {buf=buf, i=0, sz=NONE}
518 :     handle ex => (release(); outputExn (strm, "output", ex)))
519 :     fun writeDirect () = (
520 :     case !pos
521 :     of 0 => ()
522 :     | n => (#writeArr os {buf=buf, i=0, sz=SOME n}; pos := 0)
523 :     (* end case *);
524 :     #writeVec os {buf=v, i=0, sz=NONE})
525 :     handle ex => (release(); outputExn (strm, "output", ex))
526 :     fun insert copyVec = let
527 :     val bufLen = A.length buf
528 :     val dataLen = V.length v
529 :     in
530 :     if (dataLen >= bufLen)
531 :     then writeDirect()
532 :     else let
533 :     val i = !pos
534 :     val avail = bufLen - i
535 :     in
536 :     if (avail < dataLen)
537 :     then let
538 :     val _ = A.copyVec{
539 :     src=v, si=0, len=SOME avail, dst=buf, di=i
540 :     }
541 :     val _ = flushAll()
542 :     val needsFlush = copyVec(v, avail, dataLen-avail, buf, 0)
543 :     in
544 :     pos := dataLen-avail;
545 :     if needsFlush then flush () else ()
546 :     end
547 :     else let
548 :     val needsFlush = copyVec(v, 0, dataLen, buf, i)
549 :     in
550 :     pos := i + dataLen;
551 :     if (needsFlush orelse (avail = dataLen))
552 :     then flush()
553 :     else ()
554 :     end
555 :     end
556 :     end
557 :     in
558 :     case !bufferMode
559 :     of IO.NO_BUF => writeDirect ()
560 :     | IO.LINE_BUF => insert lineBufCopyVec
561 :     | IO.BLOCK_BUF => insert blockBufCopyVec
562 :     (* end case *);
563 :     release()
564 :     end
565 :    
566 :     fun output1 (strmMV, elem) = let
567 :     val (strm as OSTRM{buf, pos, bufferMode, writeArr, ...}) =
568 :     lockAndChkClosedOut (strmMV, "output1")
569 :     fun release () = SV.mPut (strmMV, strm)
570 :     in
571 :     case !bufferMode
572 :     of IO.NO_BUF => (
573 :     arrUpdate (buf, 0, elem);
574 :     writeArr {buf=buf, i=0, sz=SOME 1}
575 :     handle ex => (release(); outputExn (strm, "output1", ex)))
576 :     | IO.LINE_BUF => let val i = !pos val i' = i+1
577 :     in
578 :     arrUpdate (buf, i, elem); pos := i';
579 :     if ((i' = A.length buf) orelse (isNL elem))
580 :     then flushBuffer (strmMV, strm, "output1")
581 :     else ()
582 :     end
583 :     | IO.BLOCK_BUF => let val i = !pos val i' = i+1
584 :     in
585 :     arrUpdate (buf, i, elem); pos := i';
586 :     if (i' = A.length buf)
587 :     then flushBuffer (strmMV, strm, "output1")
588 :     else ()
589 :     end
590 :     (* end case *);
591 :     release()
592 :     end
593 :    
594 :     fun flushOut strmMV = let
595 :     val strm = lockAndChkClosedOut (strmMV, "flushOut")
596 :     in
597 :     flushBuffer (strmMV, strm, "flushOut");
598 :     SV.mPut (strmMV, strm)
599 :     end
600 :    
601 :     fun closeOut strmMV = let
602 :     val (strm as OSTRM{writer=PIO.WR{close, ...}, closed, cleanTag, ...}) =
603 :     SV.mTake strmMV
604 :     in
605 :     if !closed
606 :     then ()
607 :     else (
608 :     flushBuffer (strmMV, strm, "closeOut");
609 :     closed := true;
610 :     CleanIO.removeCleaner cleanTag;
611 :     close());
612 :     SV.mPut (strmMV, strm)
613 :     end
614 :    
615 :     fun mkOutstream (wr as PIO.WR{chunkSize, writeArr, writeVec, ...}, mode) =
616 :     let
617 :     fun iterate f (buf, i, sz) = let
618 :     fun lp (_, 0) = ()
619 :     | lp (i, n) = let val n' = f{buf=buf, i=i, sz=SOME n}
620 :     in lp (i+n', n-n') end
621 :     in
622 :     lp (i, sz)
623 :     end
624 :     fun writeArr' {buf, i, sz} = let
625 :     val len = (case sz
626 :     of NONE => A.length buf - i
627 :     | (SOME n) => n
628 :     (* end case *))
629 :     in
630 :     iterate writeArr (buf, i, len)
631 :     end
632 :     fun writeVec' {buf, i, sz} = let
633 :     val len = (case sz
634 :     of NONE => V.length buf - i
635 :     | (SOME n) => n
636 :     (* end case *))
637 :     in
638 :     iterate writeVec (buf, i, len)
639 :     end
640 :     (* install a dummy cleaner *)
641 :     val tag = CleanIO.addCleaner dummyCleaner
642 :     val strm = SV.mVarInit (OSTRM{
643 :     buf = A.array(chunkSize, someElem),
644 :     pos = ref 0,
645 :     closed = ref false,
646 :     bufferMode = ref mode,
647 :     writer = wr,
648 :     writeArr = writeArr',
649 :     writeVec = writeVec',
650 :     cleanTag = tag
651 :     })
652 :     in
653 :     CleanIO.rebindCleaner (tag, fn () => closeOut strm);
654 :     strm
655 :     end
656 :    
657 :     fun getWriter strmMV = let
658 :     val (strm as OSTRM{writer, bufferMode, ...}) =
659 :     lockAndChkClosedOut (strmMV, "getWriter")
660 :     in
661 :     (writer, !bufferMode) before SV.mPut(strmMV, strm)
662 :     end
663 :    
664 :     (** Position operations on outstreams **)
665 :     datatype out_pos = OUTP of {
666 :     pos : PIO.pos,
667 :     strm : outstream
668 :     }
669 :    
670 :     fun getPosOut strmMV = let
671 :     val (strm as OSTRM{writer, ...}) =
672 :     lockAndChkClosedOut (strmMV, "getWriter")
673 :     fun release () = SV.mPut(strmMV, strm)
674 :     in
675 :     flushBuffer (strmMV, strm, "getPosOut");
676 :     case writer
677 :     of PIO.WR{getPos=SOME f, ...} => (
678 :     OUTP{pos = f(), strm = strmMV}
679 :     handle ex => (release(); outputExn(strm, "getPosOut", ex)))
680 :     | _ => (
681 :     release();
682 :     outputExn(strm, "getPosOut", IO.RandomAccessNotSupported))
683 :     (* end case *)
684 :     before release()
685 :     end
686 :     fun filePosOut (OUTP{pos, strm=strmMV}) = (
687 :     SV.mPut (strmMV, lockAndChkClosedOut (strmMV, "filePosOut"));
688 :     pos)
689 :     fun setPosOut (OUTP{pos, strm=strmMV}) = let
690 :     val (strm as OSTRM{writer, ...}) =
691 :     lockAndChkClosedOut (strmMV, "setPosOut")
692 :     fun release () = SV.mPut(strmMV, strm)
693 :     in
694 :     case writer
695 :     of PIO.WR{setPos=SOME f, ...} => (
696 :     (f pos)
697 :     handle ex => (release(); outputExn(strm, "setPosOut", ex)))
698 :     | _ => (
699 :     release();
700 :     outputExn(strm, "getPosOut", IO.RandomAccessNotSupported))
701 :     (* end case *);
702 :     release()
703 :     end
704 :    
705 :     fun setBufferMode (strmMV, mode) = let
706 :     val (strm as OSTRM{bufferMode, ...}) =
707 :     lockAndChkClosedOut (strmMV, "setBufferMode")
708 :     in
709 :     if (mode = IO.NO_BUF)
710 :     then flushBuffer (strmMV, strm, "setBufferMode")
711 :     else ();
712 :     bufferMode := mode;
713 :     SV.mPut (strmMV, strm)
714 :     end
715 :     fun getBufferMode strmMV = let
716 :     (** should we be checking for closed streams here??? **)
717 :     val (strm as OSTRM{bufferMode, ...}) =
718 :     lockAndChkClosedOut (strmMV, "getBufferMode")
719 :     in
720 :     !bufferMode before SV.mPut (strmMV, strm)
721 :     end
722 :    
723 :     (** Text stream specific operations **)
724 :     fun outputSubstr (strmMV, ss) = let
725 :     val (strm as OSTRM os) = lockAndChkClosedOut (strmMV, "outputSubstr")
726 :     fun release () = SV.mPut (strmMV, strm)
727 :     val (v, dataStart, dataLen) = substringBase ss
728 :     val {buf, pos, bufferMode, ...} = os
729 :     val bufLen = A.length buf
730 :     fun flush () = flushBuffer (strmMV, strm, "outputSubstr")
731 :     fun flushAll () = (#writeArr os {buf=buf, i=0, sz=NONE}
732 :     handle ex => (release(); outputExn (strm, "outputSubstr", ex)))
733 :     fun writeDirect () = (
734 :     case !pos
735 :     of 0 => ()
736 :     | n => (#writeArr os {buf=buf, i=0, sz=SOME n}; pos := 0)
737 :     (* end case *);
738 :     #writeVec os {buf=v, i=dataStart, sz=SOME dataLen})
739 :     handle ex => (release(); outputExn (strm, "outputSubstr", ex))
740 :     fun insert copyVec = let
741 :     val bufLen = A.length buf
742 :     val dataLen = V.length v
743 :     in
744 :     if (dataLen >= bufLen)
745 :     then writeDirect()
746 :     else let
747 :     val i = !pos
748 :     val avail = bufLen - i
749 :     in
750 :     if (avail < dataLen)
751 :     then let
752 :     val _ = A.copyVec{
753 :     src=v, si=dataStart, len=SOME avail,
754 :     dst=buf, di=i
755 :     }
756 :     val _ = flushAll()
757 :     val needsFlush = copyVec(v, avail, dataLen-avail, buf, 0)
758 :     in
759 :     pos := dataLen-avail;
760 :     if needsFlush then flush () else ()
761 :     end
762 :     else let
763 :     val needsFlush = copyVec(v, dataStart, dataLen, buf, i)
764 :     in
765 :     pos := i + dataLen;
766 :     if (needsFlush orelse (avail = dataLen))
767 :     then flush()
768 :     else ()
769 :     end
770 :     end
771 :     end
772 :     in
773 :     case !bufferMode
774 :     of IO.NO_BUF => writeDirect ()
775 :     | IO.LINE_BUF => insert lineBufCopyVec
776 :     | IO.BLOCK_BUF => insert blockBufCopyVec
777 :     (* end case *);
778 :     release()
779 :     end
780 :    
781 :     end (* StreamIO *)
782 :    
783 :     type vector = V.vector
784 :     type elem = V.elem
785 :     type instream = StreamIO.instream SV.mvar
786 :     type outstream = StreamIO.outstream SV.mvar
787 :    
788 :     (** Input operations **)
789 :     fun input strm = let val (v, strm') = StreamIO.input(SV.mTake strm)
790 :     in
791 :     SV.mPut (strm, strm'); v
792 :     end
793 :     fun input1 strm = (case StreamIO.input1(SV.mTake strm)
794 :     of NONE => NONE
795 :     | (SOME(elem, strm')) => (SV.mPut (strm, strm'); SOME elem)
796 :     (* end case *))
797 :     fun inputN (strm, n) = let val (v, strm') = StreamIO.inputN (SV.mTake strm, n)
798 :     in
799 :     SV.mPut (strm, strm'); v
800 :     end
801 :     fun inputAll (strm : instream) = let
802 :     val (v, strm') = StreamIO.inputAll(SV.mTake strm)
803 :     in
804 :     SV.mPut (strm, strm'); v
805 :     end
806 :     fun input1Evt _ = raise Fail "input1Evt unimplemented"
807 :     fun inputEvt _ = raise Fail "inputEvt unimplemented"
808 :     fun inputNEvt _ = raise Fail "inputNEvt unimplemented"
809 :     fun inputAllEvt _ = raise Fail "inputAllEvt unimplemented"
810 :     fun canInput (strm, n) = StreamIO.canInput (SV.mGet strm, n)
811 :     fun lookahead (strm : instream) = (case StreamIO.input1(SV.mGet strm)
812 :     of NONE => NONE
813 :     | (SOME(elem, _)) => SOME elem
814 :     (* end case *))
815 :     fun closeIn strm = let
816 :     val (s as StreamIO.ISTRM(buf as StreamIO.IBUF{data, ...}, _)) =
817 :     SV.mTake strm
818 :     in
819 :     StreamIO.closeIn s;
820 :     SV.mPut(strm, StreamIO.findEOS buf)
821 :     end
822 :     fun endOfStream strm = StreamIO.endOfStream(SV.mGet strm)
823 :     fun getPosIn strm = StreamIO.getPosIn(SV.mGet strm)
824 :     fun setPosIn (strm, p) = mUpdate(strm, StreamIO.setPosIn p)
825 :    
826 :     (** Output operations **)
827 :     fun output (strm, v) = StreamIO.output(SV.mGet strm, v)
828 :     fun output1 (strm, c) = StreamIO.output1(SV.mGet strm, c)
829 :     fun flushOut strm = StreamIO.flushOut(SV.mGet strm)
830 :     fun closeOut strm = StreamIO.closeOut(SV.mGet strm)
831 :     fun getPosOut strm = StreamIO.getPosOut(SV.mGet strm)
832 :     fun setPosOut (strm, p as StreamIO.OUTP{strm=strm', ...}) = (
833 :     mUpdate(strm, strm'); StreamIO.setPosOut p)
834 :    
835 :     fun mkInstream (strm : StreamIO.instream) = SV.mVarInit strm
836 :     fun getInstream (strm : instream) = SV.mGet strm
837 :     fun setInstream (strm : instream, strm') = mUpdate(strm, strm')
838 :    
839 :     fun mkOutstream (strm : StreamIO.outstream) = SV.mVarInit strm
840 :     fun getOutstream (strm : outstream) = SV.mGet strm
841 :     fun setOutstream (strm : outstream, strm') = mUpdate(strm, strm')
842 :    
843 :     (* figure out the proper buffering mode for a given writer *)
844 :     fun bufferMode (PIO.WR{ioDesc=NONE, ...}) = IO.BLOCK_BUF
845 :     | bufferMode (PIO.WR{ioDesc=SOME iod, ...}) =
846 :     if (OS.IO.kind iod = OS.IO.Kind.tty) then IO.LINE_BUF else IO.BLOCK_BUF
847 :    
848 :     (** Open files **)
849 :     fun openIn fname =
850 :     mkInstream(StreamIO.mkInstream(OSPrimIO.openRd fname, NONE))
851 :     handle ex => raise IO.Io{function="openIn", name=fname, cause=ex}
852 :     fun openOut fname = let
853 :     val wr = OSPrimIO.openWr fname
854 :     in
855 :     mkOutstream(StreamIO.mkOutstream(wr, bufferMode wr))
856 :     handle ex => raise IO.Io{function="openOut", name=fname, cause=ex}
857 :     end
858 :     fun openAppend fname =
859 :     mkOutstream(StreamIO.mkOutstream(OSPrimIO.openApp fname, IO.NO_BUF))
860 :     handle ex => raise IO.Io{function="openAppend", name=fname, cause=ex}
861 :    
862 :     (** Text stream specific operations **)
863 :     fun inputLine strm = let val (s, strm') = StreamIO.inputLine (SV.mTake strm)
864 :     in
865 :     SV.mPut(strm, strm'); s
866 :     end
867 :     fun outputSubstr (strm, ss) = StreamIO.outputSubstr (SV.mGet strm, ss)
868 :     fun openString src =
869 :     mkInstream(StreamIO.mkInstream(OSPrimIO.strReader src, NONE))
870 :     handle ex => raise IO.Io{function="openIn", name="<string>", cause=ex}
871 :    
872 :     structure ChanIO = ChanIOFn(
873 :     structure PrimIO = PIO
874 :     structure V = CharVector
875 :     structure A = CharArray)
876 :    
877 :     (* open an instream that is connected to the output port of a channel. *)
878 :     fun openChanIn ch =
879 :     mkInstream(StreamIO.mkInstream(ChanIO.mkReader ch, NONE))
880 :    
881 :     (* open an outstream that is connected to the input port of a channel. *)
882 :     fun openChanOut ch =
883 :     mkOutstream(StreamIO.mkOutstream(ChanIO.mkWriter ch, IO.NO_BUF))
884 :    
885 :     (** Standard streams **)
886 :     local
887 :     structure SIO = StreamIO
888 :     fun mkStdIn rebind = let
889 :     val strm = SIO.mkInstream(OSPrimIO.stdIn(), NONE)
890 :     val SIO.ISTRM(SIO.IBUF{info=SIO.INFO{cleanTag, ...}, ...}, _) = strm
891 :     in
892 :     if rebind
893 :     then CleanIO.rebindCleaner (cleanTag, dummyCleaner)
894 :     else ();
895 :     strm
896 :     end
897 :     fun mkStdOut rebind = let
898 :     val wr = OSPrimIO.stdOut()
899 :     val strm = SIO.mkOutstream(wr, bufferMode wr)
900 :     val SIO.OSTRM{cleanTag, ...} = SV.mGet strm
901 :     in
902 :     if rebind
903 :     then CleanIO.rebindCleaner (cleanTag, fn () => SIO.flushOut strm)
904 :     else ();
905 :     strm
906 :     end
907 :     fun mkStdErr rebind = let
908 :     val strm = SIO.mkOutstream(OSPrimIO.stdErr(), IO.NO_BUF)
909 :     val SIO.OSTRM{cleanTag, ...} = SV.mGet strm
910 :     in
911 :     if rebind
912 :     then CleanIO.rebindCleaner (cleanTag, fn () => SIO.flushOut strm)
913 :     else ();
914 :     strm
915 :     end
916 :     in
917 :     (* build the standard streams. Since we are not currently running CML, we
918 :     * cannot do the cleaner rebinding here, but that is okay, since these are
919 :     * just place holders.
920 :     *)
921 :     val stdIn = mkInstream(mkStdIn false)
922 :     val stdOut = mkOutstream(mkStdOut false)
923 :     val stdErr = mkOutstream(mkStdErr false)
924 :    
925 :     fun print s = let val strm' = SV.mTake stdOut
926 :     in
927 :     StreamIO.output (strm', s); StreamIO.flushOut strm';
928 :     SV.mPut(stdOut, strm')
929 :     end
930 :    
931 :     (* Establish a hook function to rebuild the I/O stack *)
932 :     val _ = CleanIO.stdStrmHook := (fn () => (
933 :     setInstream (stdIn, mkStdIn true);
934 :     setOutstream (stdOut, mkStdOut true);
935 :     setOutstream (stdErr, mkStdErr true);
936 :     SMLofNJ.Internals.prHook := print))
937 :     end (* local *)
938 :    
939 :     end (* TextIOFn *)

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