[hcoop/debian/mlton.git] / basis-library / io / imperative-io.fun

(* Copyright (C) 2013,2017 Matthew Fluet.
 * Copyright (C) 2002-2007 Henry Cejtin, Matthew Fluet, Suresh
 *    Jagannathan, and Stephen Weeks.
 *
 * MLton is released under a BSD-style license.
 * See the file MLton-LICENSE for details.
 *)

signature IMPERATIVE_IO_EXTRA_ARG =
   sig
      structure Array: sig
                          include MONO_ARRAY
                          val alloc: int -> array
                          val unsafeSub: array * int -> elem
                       end
      structure ArraySlice: MONO_ARRAY_SLICE
      structure PrimIO: PRIM_IO
      structure Vector: sig 
                           include MONO_VECTOR
                           val unsafeFromArray: Array.array -> vector
                        end
      structure VectorSlice: MONO_VECTOR_SLICE
      sharing type Array.array
         = ArraySlice.array
         = PrimIO.array
      sharing type Array.elem
         = ArraySlice.elem
         = PrimIO.elem
         = Vector.elem
         = VectorSlice.elem
      sharing type Array.vector
         = ArraySlice.vector
         = PrimIO.vector
         = Vector.vector
         = VectorSlice.vector
      sharing type ArraySlice.slice
         = PrimIO.array_slice
      sharing type ArraySlice.vector_slice
         = PrimIO.vector_slice
         = VectorSlice.slice

      val chunkSize: int
      val fileTypeFlags: Posix.FileSys.O.flags list
      val line : {isLine: Vector.elem -> bool,
                  lineElem: Vector.elem} option
      val mkReader: {fd: Posix.FileSys.file_desc,
                     name: string,
                     initBlkMode: bool} -> PrimIO.reader
      val mkWriter: {fd: Posix.FileSys.file_desc,
                     name: string,
                     appendMode: bool,
                     initBlkMode: bool,
                     chunkSize: int} -> PrimIO.writer
      val someElem: PrimIO.elem
      val xlatePos : {toInt : PrimIO.pos -> Position.int, 
                      fromInt : Position.int -> PrimIO.pos} option
   end

functor ImperativeIOExtra (S: IMPERATIVE_IO_EXTRA_ARG): IMPERATIVE_IO_EXTRA =
struct

open S

structure StreamIO = StreamIOExtraFile (S)

structure PIO = PrimIO
structure SIO = StreamIO
structure A = Array
structure AS = ArraySlice
structure V = Vector
structure VS = VectorSlice

type elem = PrimIO.elem
type vector = PrimIO.vector
type vector_slice = VS.slice

(* ------------------------------------------------- *)
(*                     outstream                     *)
(* ------------------------------------------------- *)

(* The following :> hides the fact that Outstream.t is an eqtype.  Doing it
 * here is much easier than putting :> on the functor result.
 *)
structure Outstream:>
   sig
      type t

      val get: t -> SIO.outstream
      val make: SIO.outstream -> t
      val set: t *  SIO.outstream -> unit
   end =
   struct 
      datatype t = T of SIO.outstream ref

      fun get (T r) = !r
      fun set (T r, s) = r := s
      fun make s = T (ref s)
   end

type outstream = Outstream.t
fun output (os, v) = SIO.output (Outstream.get os, v)
fun output1 (os, v) = SIO.output1 (Outstream.get os, v)
fun outputSlice (os, v) = SIO.outputSlice (Outstream.get os, v)
fun flushOut os = SIO.flushOut (Outstream.get os)
fun closeOut os = SIO.closeOut (Outstream.get os)
val mkOutstream = Outstream.make
val getOutstream = Outstream.get
val setOutstream  = Outstream.set
val getPosOut = SIO.getPosOut o Outstream.get
fun setPosOut (os, outPos) = Outstream.set (os, SIO.setPosOut outPos)

fun newOut {appendMode, bufferMode, closeAtExit, fd, name} =
   let
      val writer = mkWriter {appendMode = appendMode, 
                             chunkSize = chunkSize,
                             fd = fd,
                             initBlkMode = true,
                             name = name}
      val outstream = SIO.mkOutstream'' {bufferMode = bufferMode,
                                         closeAtExit = closeAtExit,
                                         closed = false,
                                         writer = writer}
   in
      mkOutstream outstream
   end

structure PFS = Posix.FileSys

val stdErr = newOut {appendMode = true, 
                     bufferMode = IO.NO_BUF,
                     closeAtExit = false,
                     fd = PFS.stderr,
                     name = "<stderr>"}

val newOut = fn {appendMode, closeAtExit, fd, name} =>
   newOut {appendMode = appendMode,
           bufferMode = if Posix.ProcEnv.isatty fd
                            then IO.LINE_BUF
                         else IO.BLOCK_BUF,
           closeAtExit = closeAtExit,
           fd = fd,
           name = name}

val stdOut = newOut {appendMode = true,
                     closeAtExit = false,
                     fd = PFS.stdout, 
                     name = "<stdout>"}

val newOut = fn {appendMode, fd, name} =>
   newOut {appendMode = appendMode,
           closeAtExit = true,
           fd = fd,
           name = name}

fun 'a protect' (function: string, name: string, f: unit -> 'a): 'a =
   f () handle e => raise IO.Io {cause = e,
                                 function = function,
                                 name = name}

local
   val readWrite =
      let
         open PFS.S
      in
         flags [irusr, iwusr, irgrp, iwgrp, iroth, iwoth]
      end
in
   fun openOut file =
      protect'
      ("openOut", file, fn () =>
       let
          val fd = PFS.createf (file, Posix.IO.O_WRONLY, 
                                PFS.O.flags (PFS.O.trunc::fileTypeFlags), 
                                readWrite)
       in 
          newOut {fd = fd, 
                  name = file, 
                  appendMode = false}
       end)

   fun openAppend file =
      protect'
      ("openAppend", file, fn () =>
       let
          val fd = PFS.createf (file, Posix.IO.O_WRONLY,
                                PFS.O.flags (PFS.O.append::fileTypeFlags),
                                readWrite)
       in
          newOut {fd = fd, 
                  name = file, 
                  appendMode = true}
       end)
end

val newOut = fn (fd, name) => newOut {fd = fd, 
                                      name = name,
                                      appendMode = false}
val outFd = SIO.outFd o getOutstream

(* ------------------------------------------------- *)
(*                     instream                      *)
(* ------------------------------------------------- *)

datatype state = 
   Closed
 | Open of {eos: bool}
 | Stream of SIO.instream
(* Inv: if !first < !last then !state = Open {eos = false} 
 * if !state = Closed then !first = !last
 * if !state = Open {eos = true} then !first = !last
 *)

datatype instream = In of {augmentedReader: PIO.reader,
                           buf: A.array,
                           first: int ref, (* index of first character *)
                           last: int ref, (* one past the index of the last char *)
                           reader: PIO.reader,
                           state: state ref}

local
   val augmentedReader = PIO.nullRd ()
   val buf = A.alloc 0
   val first = ref 0
   val last = ref 0
   val reader = PIO.nullRd ()
in
   fun mkInstream s = In {augmentedReader = augmentedReader,
                          buf = buf,
                          first = first,
                          last = last,
                          reader = reader,
                          state = ref (Stream s)}
end

fun setInstream (In {first, last, state, ...}, s) =
   (first := 0
    ; last := 0
    ; state := Stream s)

fun equalsIn (In {first = f, ...}, In {first = f', ...}) = f = f'

fun augmentedReaderSel (In {augmentedReader = PIO.RD v, ...}, sel) = sel v

fun readerSel (In {reader = PIO.RD v, ...}, sel) = sel v

fun inbufferName ib = readerSel (ib, #name)

fun inFd ib =
   case readerSel (ib, #ioDesc) of
      NONE => raise IO.Io {cause = Fail "<no ioDesc>",
                           function = "inFd",
                           name = inbufferName ib}
    | SOME ioDesc => valOf (Posix.FileSys.iodToFD ioDesc)

val empty = V.tabulate (0, fn _ => someElem)

local
   fun make (sel, e: exn) ib =
      case augmentedReaderSel (ib, sel) of
         NONE => raise e
       | SOME x => x
in
   val readArr = make (#readArr, IO.BlockingNotSupported)
   val readArrNB = make (#readArrNB, IO.NonblockingNotSupported)
   val readVec = make (#readVec, IO.BlockingNotSupported)
end

fun 'a protect (ib, function: string, f: unit -> 'a): 'a =
   f () handle e => raise IO.Io {cause = e,
                                 function = function,
                                 name = inbufferName ib}

fun update (ib as In {buf, first, last, state, ...}) =
   let
      val i = readArr ib (AS.full buf)
   in
      if i = 0
         then (state := Open {eos = true}
               ; false)
      else (first := 0
            ; last := i
            ; true)
   end

fun input (ib as In {buf, first, last, ...}) =
   let
      val f = !first
      val l = !last
   in
      if f < l
         then (first := l
               ; AS.vector (AS.slice (buf, f, SOME (l - f))))
      else
         let
            val In {state, ...} = ib
         in
            case !state of
               Closed => empty
             | Open {eos} =>
                  if eos
                     then (state := Open {eos = false}
                           ; empty)
                  else protect (ib, "input", fn () =>
                                readVec ib (augmentedReaderSel (ib, #chunkSize)))
             | Stream s =>
                  let
                     val (v, s') = SIO.input s
                     val _ = state := Stream s'
                  in
                     v
                  end
         end
   end

(* input1 will move past a temporary end of stream *)
fun input1 (ib as In {buf, first, last, ...}) =
   let
      val f = !first
   in
      if f < !last
         then (first := f + 1
               ; SOME (A.unsafeSub (buf, f)))
      else
         let
            val In {state, ...} = ib
         in
            case !state of
               Closed => NONE
             | Open {eos} =>
                  if eos
                     then
                        (state := Open {eos = false}
                         ; NONE)
                  else
                     if protect (ib, "input1", fn () => update ib)
                        then
                           (first := 1
                            ; SOME (A.sub (buf, 0)))
                     else NONE
             | Stream s =>
                  let
                     val (c, s') = SIO.input1' s
                     val _ = state := Stream s'
                  in
                     c
                  end
         end
   end

fun inputN (ib as In {buf, first, last, ...}, n) =
   if n < 0 orelse n > V.maxLen
      then raise Size
   else
      let
         val f = !first
         val l = !last
         val size = l - f
      in
         if size >= n
            then (first := f + n
                  ; AS.vector (AS.slice (buf, f, SOME n)))
         else
            let
               val In {state, ...} = ib
            in
               case !state of
                  Closed => empty
                | Open {eos} =>
                     if eos
                        then (state := Open {eos = false}
                              ; empty)
                     else
                        protect
                        (ib, "inputN", fn () =>
                         let
                            val readArr = readArr ib
                            val inp = A.alloc n
                            fun fill k =
                               if k >= size
                                  then ()
                               else (A.update (inp, k, A.sub (buf, f + k))
                                     ; fill (k + 1))
                            val _ = fill 0
                            val _ = first := l
                            fun loop i =
                               if i = n
                                  then i
                               else let
                                       val j = 
                                          readArr
                                          (AS.slice (inp, i, SOME (n - i)))
                                    in
                                       if j = 0
                                          then (state := Open {eos = true}; i)
                                       else loop (i + j)
                                    end
                            val i = loop size
                         in
                            if i = n
                               then V.unsafeFromArray inp
                            else AS.vector (AS.slice (inp, 0, SOME i))
                         end)
                | Stream s =>
                     let
                        val (v, s') = SIO.inputN (s, n)
                        val _ = state := Stream s'
                     in
                        v
                     end
            end
      end

fun inputAll (ib as In {state, ...}) =
   case !state of
      Closed => empty
    | Open {eos} =>
         if eos
            then (state := Open {eos = false}
                  ; empty)
         else
            protect
            (ib, "inputAll", fn () =>
             let
                val In {buf, first, last, ...} = ib
                val readVec = readVec ib
                val f = !first
                val l = !last
                val inp = AS.vector (AS.slice (buf, f, SOME (l - f)))
                val inps = [inp]
                fun loop inps =
                   let
                      val inp =
                         readVec (augmentedReaderSel (ib, #chunkSize))
                   in
                      if V.length inp = 0
                         then V.concat (List.rev inps)
                      else loop (inp :: inps)
                   end
             in
                loop inps
             end)
    | Stream s =>
          let
             val (v, s') = SIO.inputAll s
             val _ = state := Stream s'
          in
             v
          end

val inputLine =
   case line of
      NONE => (fn ib => SOME (input ib))
    | SOME {isLine, lineElem} =>
         let
            val lineVec = V.tabulate (1, fn _ => lineElem)
         in
            fn (ib as In {state, ...}) =>
            case !state of
               Closed => NONE
             | Open {eos} =>
                  if eos
                      then NONE
                  else
                     protect
                     (ib, "inputLine", fn () =>
                      let
                         val In {buf, first, last, ...} = ib
                         fun finish (inps, trail) =
                            let
                               val inps = if trail
                                             then lineVec :: inps
                                          else inps
                               val inp = V.concat (List.rev inps)
                            in
                               SOME inp
                            end
                         fun loop inps =
                            if !first < !last orelse update ib
                               then
                                  let
                                     val f = !first
                                     val l = !last
                                     (* !first < !last *) 
                                     fun loop' i = (* pre: !first <= i <= !last *)
                                        let
                                           fun done j = (* pre: !first < j <= !last *)
                                              let
                                                 val inp = AS.vector (AS.slice (buf, f, SOME (j - f)))
                                              in
                                                 first := j;
                                                 inp::inps
                                              end
                                        in
                                           if i >= l
                                              then loop (done i)
                                           else if isLine (A.sub (buf, i))
                                                   then finish (done (i + 1), false)
                                                else loop' (i + 1)
                                        end
                                  in
                                     loop' f
                                  end
                            else (case inps of
                                     [] => NONE
                                   | _ => finish (inps, true))
                      in
                         loop []
                      end)
             | Stream s =>
                  Option.map
                  (fn (v, s') => (state := Stream s'; v))
                  (SIO.inputLine s)
         end

fun canInput (ib as In {state, ...}, n) =
   if n < 0 orelse n > V.maxLen
      then raise Size
   else
      case !state of
         Closed => SOME 0
       | Open {eos} =>
            if eos
               then SOME 0
            else
               protect
               (ib, "canInput", fn () =>
                let
                   val readArrNB = readArrNB ib
                   val In {buf, first, last, ...} = ib
                   val f = !first
                   val l = !last
                   val read = l - f
                   val _ =
                      if f > 0
                         then
                            (AS.copy {di = 0,
                                      dst = buf,
                                      src = AS.slice (buf, f, SOME read)}
                             ; first := 0)
                      else ()
                   val size = A.length buf
                   (* 0 = !first *)
                   fun loop read =
                      if read = size
                         then {read = read, eos = false}
                      else
                         let
                            val slice = AS.slice (buf, read, NONE)
                            val i = readArrNB slice
                         in
                            case i of
                               NONE => {read = read, eos = false}
                             | SOME i =>
                                  if 0 = i
                                     then {read = read, eos = true}
                                  else loop (read + i)
                         end
                   val {read, eos} = loop read
                   val _ = last := read
                in
                   if read > 0
                      then SOME (Int.min (n, read))
                   else if eos
                      then (state := Open {eos = true}; SOME 0)
                   else NONE
                end)
       | Stream s => SIO.canInput (s, n)

fun lookahead (ib as In {buf, first, last, ...}) =
   let
      val f = !first
      val l = !last
   in
      if f < l
         then SOME (A.unsafeSub (buf, f))
      else
         let
            val In {state, ...} = ib
         in
            case !state of
               Closed => NONE
             | Open {eos, ...} =>
                  if eos
                     then NONE
                  else if protect (ib, "lookahead", fn () => update ib)
                          then SOME (A.sub (buf, 0))
                       else NONE
             | Stream s => Option.map #1 (SIO.input1 s)
         end
   end

fun closeIn (ib as In {first, last, state, ...}) =
   case !state of
      Closed => ()
    | Open _ =>
         (first := !last
          ; state := Closed
          ; protect (ib, "closeIn", fn () => readerSel (ib, #close) ()))
    | Stream s => SIO.closeIn s

fun endOfStream (ib as In {first, last, state, ...}) =
   !first = !last
   andalso
   (case !state of
       Closed => true
     | Open {eos, ...} =>
          eos orelse not (protect (ib, "endOfStream", fn () => update ib))
     | Stream s => SIO.endOfStream s)

fun mkInbuffer' {reader, closed, bufferContents} =
   let
      val (state, first, last, buf) =
         if closed
            then (ref Closed, ref 0, ref 0, Array.array (0, someElem))
         else let
                 val PIO.RD {chunkSize, ...} = reader
                 val buf = Array.array (chunkSize, someElem)
                 val first = ref 0
                 val (state, last) =
                    case bufferContents of
                       NONE => (ref (Open {eos = false}), ref 0)
                     | SOME v =>
                          if V.length v = 0
                             then (ref (Open {eos = true}), ref 0)
                          else (V.appi (fn (i, c) => A.update (buf, i, c)) v
                                ; (ref (Open {eos = false}), ref (V.length v)))
              in
                 (state, first, last, buf)
              end
   in
      In {augmentedReader = PIO.augmentReader reader,
          buf = buf,
          first = first,
          last = last,
          reader = reader,
          state = state}
   end

fun openVector v = 
   mkInbuffer' {bufferContents = NONE,
                closed = false,
                reader = PIO.openVector v}

val openInbuffers : (instream * {close: bool}) list ref = ref []

fun getInstream (ib as In {state, ...}) =
   let
      fun doit (closed: bool, bufferContents) =
         let
            val In {reader, ...} = ib
            val (ibs, openInbuffers') =
               List.partition (fn (ib', _) => equalsIn (ib, ib'))
               (!openInbuffers)
            val _ = openInbuffers := openInbuffers'
            val closeAtExit = 
               List.foldr (fn ((_, {close = close'}), close) =>
                           close orelse close')
               false ibs
         in
            SIO.mkInstream'' {bufferContents = bufferContents,
                              closeAtExit = closeAtExit,
                              closed = closed,
                              reader = reader}
         end
   in
      case !state of
         Closed => doit (true, NONE)
       | Open {eos} =>
            if eos
               then doit (false, SOME (true, empty))
            else
               let
                  val In {buf, first, last, ...} = ib
                  val f = !first
                  val l = !last
                  val s =
                     if f < l
                        then 
                           doit (false,
                                 SOME (true, 
                                       AS.vector (AS.slice (buf, f, 
                                                            SOME (l - f)))))
                        else doit (false, NONE)
                  val () = state := Stream s
               in
                  s
               end
       | Stream s => s
   end

val mkInbuffer'' =
   let
      val _ =
         Cleaner.addNew
         (Cleaner.atExit, fn () =>
          List.app (fn (ib, {close}) => if close then closeIn ib else ())
          (!openInbuffers))
   in
      fn {bufferContents, closeAtExit, closed, reader} =>
      let
         val ib = mkInbuffer' {bufferContents = bufferContents,
                               closed = closed,
                               reader = reader}
         val _ = if closed
                    then ()
                 else openInbuffers := ((ib, {close = closeAtExit})
                                        :: (!openInbuffers))
      in
         ib
      end
   end

fun scanStream f is =
   case f SIO.input1 (getInstream is) of
      NONE => NONE
    | SOME (v, s') => (setInstream (is, s'); SOME v)

val closeIn = fn ib =>
   let
      val _ = openInbuffers := List.filter (fn (ib',_) => 
                                            not (equalsIn (ib, ib'))) 
         (!openInbuffers)
   in
      closeIn ib
   end

fun newIn {bufferContents, closeAtExit, fd, name} =
   let 
      val reader = mkReader {fd = fd, initBlkMode = true, name = name}
   in
      mkInbuffer'' {bufferContents = bufferContents,
                    closeAtExit = closeAtExit,
                    closed = false,
                    reader = reader}
   end

val newIn = fn (fd, name) =>
   newIn {bufferContents = NONE,
          closeAtExit = true,
          fd = fd,
          name = name}

val stdIn = newIn (PFS.stdin, "<stdin>")

fun openIn file =
   protect'
   ("openIn", file, fn () =>
    let 
       val fd = PFS.openf (file, Posix.IO.O_RDONLY, PFS.O.flags fileTypeFlags)
    in 
       newIn (fd, file)
    end)

end

signature IMPERATIVE_IO_ARG =
   sig
      structure Array: MONO_ARRAY
(*      structure ArraySlice: MONO_ARRAY_SLICE *)
      structure StreamIO: STREAM_IO
      structure Vector: MONO_VECTOR
(*      structure VectorSlice: MONO_VECTOR_SLICE *)
(*      sharing type Array.array = ArraySlice.array *)
      sharing type
         Array.elem
(*       = ArraySlice.elem *)
         = StreamIO.elem
         = Vector.elem
(*       = VectorSlice.elem *)
      sharing type
         Array.vector
(*       = ArraySlice.vector *)
         = Vector.vector
(*       = VectorSlice.vector *)
(*      sharing type ArraySlice.vector_slice = VectorSlice.slice *)
   end

functor ImperativeIO (S: IMPERATIVE_IO_ARG): IMPERATIVE_IO =
   struct
      open S

      structure SIO = StreamIO

      type elem = SIO.elem
      type vector = SIO.vector

      datatype outstream = Out of SIO.outstream ref

      fun output (Out os, v) = SIO.output (!os, v)
      fun output1 (Out os, v) = SIO.output1 (!os, v)
      fun flushOut (Out os) = SIO.flushOut (!os)
      fun closeOut (Out os) = SIO.closeOut (!os)
      fun mkOutstream os = Out (ref os)
      fun getOutstream (Out os) = !os
      fun setOutstream (Out os, os') = os := os'
      fun getPosOut (Out os) = SIO.getPosOut (!os)
      fun setPosOut (Out os, out_pos) = os := SIO.setPosOut out_pos

      datatype instream = In of SIO.instream ref

      fun canInput (In is, n) = SIO.canInput (!is, n)
      fun closeIn (In is) = SIO.closeIn (!is)
      fun endOfStream (In is) = SIO.endOfStream (!is)
      fun getInstream (In is) = !is
      fun input (In is) = let val (v, is') = SIO.input (!is)
                          in is := is'; v
                          end 
      (* input1 will never move past a temporary end of stream *)
      fun input1 (In is) = 
        case SIO.input1 (!is) of
          SOME (c,is') => (is := is'; SOME c)
        | NONE => NONE
      fun inputAll (In is) = let val (v, is') = SIO.inputAll (!is)
                             in is := is'; v
                             end
      fun inputN (In is, n) = let val (v, is') = SIO.inputN (!is, n)
                              in is := is'; v
                              end
      fun lookahead (In is) =
         Option.map #1 (SIO.input1 (!is))
      fun mkInstream is = In (ref is)
      fun setInstream (In is, is') = is := is'
   end
Commit	Line	Data
7f918cf1 CE	1	(* Copyright (C) 2013,2017 Matthew Fluet.
	2	* Copyright (C) 2002-2007 Henry Cejtin, Matthew Fluet, Suresh
	3	* Jagannathan, and Stephen Weeks.
	4	*
	5	* MLton is released under a BSD-style license.
	6	* See the file MLton-LICENSE for details.
	7	*)
	8
	9	signature IMPERATIVE_IO_EXTRA_ARG =
	10	sig
	11	structure Array: sig
	12	include MONO_ARRAY
	13	val alloc: int -> array
	14	val unsafeSub: array * int -> elem
	15	end
	16	structure ArraySlice: MONO_ARRAY_SLICE
	17	structure PrimIO: PRIM_IO
	18	structure Vector: sig
	19	include MONO_VECTOR
	20	val unsafeFromArray: Array.array -> vector
	21	end
	22	structure VectorSlice: MONO_VECTOR_SLICE
	23	sharing type Array.array
	24	= ArraySlice.array
	25	= PrimIO.array
	26	sharing type Array.elem
	27	= ArraySlice.elem
	28	= PrimIO.elem
	29	= Vector.elem
	30	= VectorSlice.elem
	31	sharing type Array.vector
	32	= ArraySlice.vector
	33	= PrimIO.vector
	34	= Vector.vector
	35	= VectorSlice.vector
	36	sharing type ArraySlice.slice
	37	= PrimIO.array_slice
	38	sharing type ArraySlice.vector_slice
	39	= PrimIO.vector_slice
	40	= VectorSlice.slice
	41
	42	val chunkSize: int
	43	val fileTypeFlags: Posix.FileSys.O.flags list
	44	val line : {isLine: Vector.elem -> bool,
	45	lineElem: Vector.elem} option
	46	val mkReader: {fd: Posix.FileSys.file_desc,
	47	name: string,
	48	initBlkMode: bool} -> PrimIO.reader
	49	val mkWriter: {fd: Posix.FileSys.file_desc,
	50	name: string,
	51	appendMode: bool,
	52	initBlkMode: bool,
	53	chunkSize: int} -> PrimIO.writer
	54	val someElem: PrimIO.elem
	55	val xlatePos : {toInt : PrimIO.pos -> Position.int,
	56	fromInt : Position.int -> PrimIO.pos} option
	57	end
	58
	59	functor ImperativeIOExtra (S: IMPERATIVE_IO_EXTRA_ARG): IMPERATIVE_IO_EXTRA =
	60	struct
	61
	62	open S
	63
	64	structure StreamIO = StreamIOExtraFile (S)
65
66	structure PIO = PrimIO
67	structure SIO = StreamIO
68	structure A = Array
69	structure AS = ArraySlice
70	structure V = Vector
71	structure VS = VectorSlice
72
73	type elem = PrimIO.elem
74	type vector = PrimIO.vector
75	type vector_slice = VS.slice
76
77	(* ------------------------------------------------- *)
78	(* outstream *)
79	(* ------------------------------------------------- *)
80
81	(* The following :> hides the fact that Outstream.t is an eqtype. Doing it
82	* here is much easier than putting :> on the functor result.
83	*)
84	structure Outstream:>
85	sig
86	type t
87
88	val get: t -> SIO.outstream
89	val make: SIO.outstream -> t
90	val set: t * SIO.outstream -> unit
91	end =
92	struct
93	datatype t = T of SIO.outstream ref
94
95	fun get (T r) = !r
96	fun set (T r, s) = r := s
97	fun make s = T (ref s)
98	end
99
100	type outstream = Outstream.t
101	fun output (os, v) = SIO.output (Outstream.get os, v)
102	fun output1 (os, v) = SIO.output1 (Outstream.get os, v)
103	fun outputSlice (os, v) = SIO.outputSlice (Outstream.get os, v)
104	fun flushOut os = SIO.flushOut (Outstream.get os)
105	fun closeOut os = SIO.closeOut (Outstream.get os)
106	val mkOutstream = Outstream.make
107	val getOutstream = Outstream.get
108	val setOutstream = Outstream.set
109	val getPosOut = SIO.getPosOut o Outstream.get
110	fun setPosOut (os, outPos) = Outstream.set (os, SIO.setPosOut outPos)
111
112	fun newOut {appendMode, bufferMode, closeAtExit, fd, name} =
113	let
114	val writer = mkWriter {appendMode = appendMode,
115	chunkSize = chunkSize,
116	fd = fd,
117	initBlkMode = true,
118	name = name}
119	val outstream = SIO.mkOutstream'' {bufferMode = bufferMode,
120	closeAtExit = closeAtExit,
121	closed = false,
122	writer = writer}
123	in
124	mkOutstream outstream
125	end
126
127	structure PFS = Posix.FileSys
128
129	val stdErr = newOut {appendMode = true,
130	bufferMode = IO.NO_BUF,
131	closeAtExit = false,
132	fd = PFS.stderr,
133	name = "<stderr>"}
134
135	val newOut = fn {appendMode, closeAtExit, fd, name} =>
136	newOut {appendMode = appendMode,
137	bufferMode = if Posix.ProcEnv.isatty fd
138	then IO.LINE_BUF
139	else IO.BLOCK_BUF,
140	closeAtExit = closeAtExit,
141	fd = fd,
142	name = name}
143
144	val stdOut = newOut {appendMode = true,
145	closeAtExit = false,
146	fd = PFS.stdout,
147	name = "<stdout>"}
148
149	val newOut = fn {appendMode, fd, name} =>
150	newOut {appendMode = appendMode,
151	closeAtExit = true,
152	fd = fd,
153	name = name}
154
155	fun 'a protect' (function: string, name: string, f: unit -> 'a): 'a =
156	f () handle e => raise IO.Io {cause = e,
157	function = function,
158	name = name}
159
160	local
161	val readWrite =
162	let
163	open PFS.S
164	in
165	flags [irusr, iwusr, irgrp, iwgrp, iroth, iwoth]
166	end
167	in
168	fun openOut file =
169	protect'
170	("openOut", file, fn () =>
171	let
172	val fd = PFS.createf (file, Posix.IO.O_WRONLY,
173	PFS.O.flags (PFS.O.trunc::fileTypeFlags),
174	readWrite)
175	in
176	newOut {fd = fd,
177	name = file,
178	appendMode = false}
179	end)
180
181	fun openAppend file =
182	protect'
183	("openAppend", file, fn () =>
184	let
185	val fd = PFS.createf (file, Posix.IO.O_WRONLY,
186	PFS.O.flags (PFS.O.append::fileTypeFlags),
187	readWrite)
188	in
189	newOut {fd = fd,
190	name = file,
191	appendMode = true}
192	end)
193	end
194
195	val newOut = fn (fd, name) => newOut {fd = fd,
196	name = name,
197	appendMode = false}
198	val outFd = SIO.outFd o getOutstream
199
200	(* ------------------------------------------------- *)
201	(* instream *)
202	(* ------------------------------------------------- *)
203
204	datatype state =
205	Closed
206	\| Open of {eos: bool}
207	\| Stream of SIO.instream
208	(* Inv: if !first < !last then !state = Open {eos = false}
209	* if !state = Closed then !first = !last
210	* if !state = Open {eos = true} then !first = !last
211	*)
212
213	datatype instream = In of {augmentedReader: PIO.reader,
214	buf: A.array,
215	first: int ref, (* index of first character *)
216	last: int ref, (* one past the index of the last char *)
217	reader: PIO.reader,
218	state: state ref}
219
220	local
221	val augmentedReader = PIO.nullRd ()
222	val buf = A.alloc 0
223	val first = ref 0
224	val last = ref 0
225	val reader = PIO.nullRd ()
226	in
227	fun mkInstream s = In {augmentedReader = augmentedReader,
228	buf = buf,
229	first = first,
230	last = last,
231	reader = reader,
232	state = ref (Stream s)}
233	end
234
235	fun setInstream (In {first, last, state, ...}, s) =
236	(first := 0
237	; last := 0
238	; state := Stream s)
239
240	fun equalsIn (In {first = f, ...}, In {first = f', ...}) = f = f'
241
242	fun augmentedReaderSel (In {augmentedReader = PIO.RD v, ...}, sel) = sel v
243
244	fun readerSel (In {reader = PIO.RD v, ...}, sel) = sel v
245
246	fun inbufferName ib = readerSel (ib, #name)
247
248	fun inFd ib =
249	case readerSel (ib, #ioDesc) of
250	NONE => raise IO.Io {cause = Fail "<no ioDesc>",
251	function = "inFd",
252	name = inbufferName ib}
253	\| SOME ioDesc => valOf (Posix.FileSys.iodToFD ioDesc)
254
255	val empty = V.tabulate (0, fn _ => someElem)
256
257	local
258	fun make (sel, e: exn) ib =
259	case augmentedReaderSel (ib, sel) of
260	NONE => raise e
261	\| SOME x => x
262	in
263	val readArr = make (#readArr, IO.BlockingNotSupported)
264	val readArrNB = make (#readArrNB, IO.NonblockingNotSupported)
265	val readVec = make (#readVec, IO.BlockingNotSupported)
266	end
267
268	fun 'a protect (ib, function: string, f: unit -> 'a): 'a =
269	f () handle e => raise IO.Io {cause = e,
270	function = function,
271	name = inbufferName ib}
272
273	fun update (ib as In {buf, first, last, state, ...}) =
274	let
275	val i = readArr ib (AS.full buf)
276	in
277	if i = 0
278	then (state := Open {eos = true}
279	; false)
280	else (first := 0
281	; last := i
282	; true)
283	end
284
285	fun input (ib as In {buf, first, last, ...}) =
286	let
287	val f = !first
288	val l = !last
289	in
290	if f < l
291	then (first := l
292	; AS.vector (AS.slice (buf, f, SOME (l - f))))
293	else
294	let
295	val In {state, ...} = ib
296	in
297	case !state of
298	Closed => empty
299	\| Open {eos} =>
300	if eos
301	then (state := Open {eos = false}
302	; empty)
303	else protect (ib, "input", fn () =>
304	readVec ib (augmentedReaderSel (ib, #chunkSize)))
305	\| Stream s =>
306	let
307	val (v, s') = SIO.input s
308	val _ = state := Stream s'
309	in
310	v
311	end
312	end
313	end
314
315	(* input1 will move past a temporary end of stream *)
316	fun input1 (ib as In {buf, first, last, ...}) =
317	let
318	val f = !first
319	in
320	if f < !last
321	then (first := f + 1
322	; SOME (A.unsafeSub (buf, f)))
323	else
324	let
325	val In {state, ...} = ib
326	in
327	case !state of
328	Closed => NONE
329	\| Open {eos} =>
330	if eos
331	then
332	(state := Open {eos = false}
333	; NONE)
334	else
335	if protect (ib, "input1", fn () => update ib)
336	then
337	(first := 1
338	; SOME (A.sub (buf, 0)))
339	else NONE
340	\| Stream s =>
341	let
342	val (c, s') = SIO.input1' s
343	val _ = state := Stream s'
344	in
345	c
346	end
347	end
348	end
349
350	fun inputN (ib as In {buf, first, last, ...}, n) =
351	if n < 0 orelse n > V.maxLen
352	then raise Size
353	else
354	let
355	val f = !first
356	val l = !last
357	val size = l - f
358	in
359	if size >= n
360	then (first := f + n
361	; AS.vector (AS.slice (buf, f, SOME n)))
362	else
363	let
364	val In {state, ...} = ib
365	in
366	case !state of
367	Closed => empty
368	\| Open {eos} =>
369	if eos
370	then (state := Open {eos = false}
371	; empty)
372	else
373	protect
374	(ib, "inputN", fn () =>
375	let
376	val readArr = readArr ib
377	val inp = A.alloc n
378	fun fill k =
379	if k >= size
380	then ()
381	else (A.update (inp, k, A.sub (buf, f + k))
382	; fill (k + 1))
383	val _ = fill 0
384	val _ = first := l
385	fun loop i =
386	if i = n
387	then i
388	else let
389	val j =
390	readArr
391	(AS.slice (inp, i, SOME (n - i)))
392	in
393	if j = 0
394	then (state := Open {eos = true}; i)
395	else loop (i + j)
396	end
397	val i = loop size
398	in
399	if i = n
400	then V.unsafeFromArray inp
401	else AS.vector (AS.slice (inp, 0, SOME i))
402	end)
403	\| Stream s =>
404	let
405	val (v, s') = SIO.inputN (s, n)
406	val _ = state := Stream s'
407	in
408	v
409	end
410	end
411	end
412
413	fun inputAll (ib as In {state, ...}) =
414	case !state of
415	Closed => empty
416	\| Open {eos} =>
417	if eos
418	then (state := Open {eos = false}
419	; empty)
420	else
421	protect
422	(ib, "inputAll", fn () =>
423	let
424	val In {buf, first, last, ...} = ib
425	val readVec = readVec ib
426	val f = !first
427	val l = !last
428	val inp = AS.vector (AS.slice (buf, f, SOME (l - f)))
429	val inps = [inp]
430	fun loop inps =
431	let
432	val inp =
433	readVec (augmentedReaderSel (ib, #chunkSize))
434	in
435	if V.length inp = 0
436	then V.concat (List.rev inps)
437	else loop (inp :: inps)
438	end
439	in
440	loop inps
441	end)
442	\| Stream s =>
443	let
444	val (v, s') = SIO.inputAll s
445	val _ = state := Stream s'
446	in
447	v
448	end
449
450	val inputLine =
451	case line of
452	NONE => (fn ib => SOME (input ib))
453	\| SOME {isLine, lineElem} =>
454	let
455	val lineVec = V.tabulate (1, fn _ => lineElem)
456	in
457	fn (ib as In {state, ...}) =>
458	case !state of
459	Closed => NONE
460	\| Open {eos} =>
461	if eos
462	then NONE
463	else
464	protect
465	(ib, "inputLine", fn () =>
466	let
467	val In {buf, first, last, ...} = ib
468	fun finish (inps, trail) =
469	let
470	val inps = if trail
471	then lineVec :: inps
472	else inps
473	val inp = V.concat (List.rev inps)
474	in
475	SOME inp
476	end
477	fun loop inps =
478	if !first < !last orelse update ib
479	then
480	let
481	val f = !first
482	val l = !last
483	(* !first < !last *)
484	fun loop' i = (* pre: !first <= i <= !last *)
485	let
486	fun done j = (* pre: !first < j <= !last *)
487	let
488	val inp = AS.vector (AS.slice (buf, f, SOME (j - f)))
489	in
490	first := j;
491	inp::inps
492	end
493	in
494	if i >= l
495	then loop (done i)
496	else if isLine (A.sub (buf, i))
497	then finish (done (i + 1), false)
498	else loop' (i + 1)
499	end
500	in
501	loop' f
502	end
503	else (case inps of
504	[] => NONE
505	\| _ => finish (inps, true))
506	in
507	loop []
508	end)
509	\| Stream s =>
510	Option.map
511	(fn (v, s') => (state := Stream s'; v))
512	(SIO.inputLine s)
513	end
514
515	fun canInput (ib as In {state, ...}, n) =
516	if n < 0 orelse n > V.maxLen
517	then raise Size
518	else
519	case !state of
520	Closed => SOME 0
521	\| Open {eos} =>
522	if eos
523	then SOME 0
524	else
525	protect
526	(ib, "canInput", fn () =>
527	let
528	val readArrNB = readArrNB ib
529	val In {buf, first, last, ...} = ib
530	val f = !first
531	val l = !last
532	val read = l - f
533	val _ =
534	if f > 0
535	then
536	(AS.copy {di = 0,
537	dst = buf,
538	src = AS.slice (buf, f, SOME read)}
539	; first := 0)
540	else ()
541	val size = A.length buf
542	(* 0 = !first *)
543	fun loop read =
544	if read = size
545	then {read = read, eos = false}
546	else
547	let
548	val slice = AS.slice (buf, read, NONE)
549	val i = readArrNB slice
550	in
551	case i of
552	NONE => {read = read, eos = false}
553	\| SOME i =>
554	if 0 = i
555	then {read = read, eos = true}
556	else loop (read + i)
557	end
558	val {read, eos} = loop read
559	val _ = last := read
560	in
561	if read > 0
562	then SOME (Int.min (n, read))
563	else if eos
564	then (state := Open {eos = true}; SOME 0)
565	else NONE
566	end)
567	\| Stream s => SIO.canInput (s, n)
568
569	fun lookahead (ib as In {buf, first, last, ...}) =
570	let
571	val f = !first
572	val l = !last
573	in
574	if f < l
575	then SOME (A.unsafeSub (buf, f))
576	else
577	let
578	val In {state, ...} = ib
579	in
580	case !state of
581	Closed => NONE
582	\| Open {eos, ...} =>
583	if eos
584	then NONE
585	else if protect (ib, "lookahead", fn () => update ib)
586	then SOME (A.sub (buf, 0))
587	else NONE
588	\| Stream s => Option.map #1 (SIO.input1 s)
589	end
590	end
591
592	fun closeIn (ib as In {first, last, state, ...}) =
593	case !state of
594	Closed => ()
595	\| Open _ =>
596	(first := !last
597	; state := Closed
598	; protect (ib, "closeIn", fn () => readerSel (ib, #close) ()))
599	\| Stream s => SIO.closeIn s
600
601	fun endOfStream (ib as In {first, last, state, ...}) =
602	!first = !last
603	andalso
604	(case !state of
605	Closed => true
606	\| Open {eos, ...} =>
607	eos orelse not (protect (ib, "endOfStream", fn () => update ib))
608	\| Stream s => SIO.endOfStream s)
609
610	fun mkInbuffer' {reader, closed, bufferContents} =
611	let
612	val (state, first, last, buf) =
613	if closed
614	then (ref Closed, ref 0, ref 0, Array.array (0, someElem))
615	else let
616	val PIO.RD {chunkSize, ...} = reader
617	val buf = Array.array (chunkSize, someElem)
618	val first = ref 0
619	val (state, last) =
620	case bufferContents of
621	NONE => (ref (Open {eos = false}), ref 0)
622	\| SOME v =>
623	if V.length v = 0
624	then (ref (Open {eos = true}), ref 0)
625	else (V.appi (fn (i, c) => A.update (buf, i, c)) v
626	; (ref (Open {eos = false}), ref (V.length v)))
627	in
628	(state, first, last, buf)
629	end
630	in
631	In {augmentedReader = PIO.augmentReader reader,
632	buf = buf,
633	first = first,
634	last = last,
635	reader = reader,
636	state = state}
637	end
638
639	fun openVector v =
640	mkInbuffer' {bufferContents = NONE,
641	closed = false,
642	reader = PIO.openVector v}
643
644	val openInbuffers : (instream * {close: bool}) list ref = ref []
645
646	fun getInstream (ib as In {state, ...}) =
647	let
648	fun doit (closed: bool, bufferContents) =
649	let
650	val In {reader, ...} = ib
651	val (ibs, openInbuffers') =
652	List.partition (fn (ib', _) => equalsIn (ib, ib'))
653	(!openInbuffers)
654	val _ = openInbuffers := openInbuffers'
655	val closeAtExit =
656	List.foldr (fn ((_, {close = close'}), close) =>
657	close orelse close')
658	false ibs
659	in
660	SIO.mkInstream'' {bufferContents = bufferContents,
661	closeAtExit = closeAtExit,
662	closed = closed,
663	reader = reader}
664	end
665	in
666	case !state of
667	Closed => doit (true, NONE)
668	\| Open {eos} =>
669	if eos
670	then doit (false, SOME (true, empty))
671	else
672	let
673	val In {buf, first, last, ...} = ib
674	val f = !first
675	val l = !last
676	val s =
677	if f < l
678	then
679	doit (false,
680	SOME (true,
681	AS.vector (AS.slice (buf, f,
682	SOME (l - f)))))
683	else doit (false, NONE)
684	val () = state := Stream s
685	in
686	s
687	end
688	\| Stream s => s
689	end
690
691	val mkInbuffer'' =
692	let
693	val _ =
694	Cleaner.addNew
695	(Cleaner.atExit, fn () =>
696	List.app (fn (ib, {close}) => if close then closeIn ib else ())
697	(!openInbuffers))
698	in
699	fn {bufferContents, closeAtExit, closed, reader} =>
700	let
701	val ib = mkInbuffer' {bufferContents = bufferContents,
702	closed = closed,
703	reader = reader}
704	val _ = if closed
705	then ()
706	else openInbuffers := ((ib, {close = closeAtExit})
707	:: (!openInbuffers))
708	in
709	ib
710	end
711	end
712
713	fun scanStream f is =
714	case f SIO.input1 (getInstream is) of
715	NONE => NONE
716	\| SOME (v, s') => (setInstream (is, s'); SOME v)
717
718	val closeIn = fn ib =>
719	let
720	val _ = openInbuffers := List.filter (fn (ib',_) =>
721	not (equalsIn (ib, ib')))
722	(!openInbuffers)
723	in
724	closeIn ib
725	end
726
727	fun newIn {bufferContents, closeAtExit, fd, name} =
728	let
729	val reader = mkReader {fd = fd, initBlkMode = true, name = name}
730	in
731	mkInbuffer'' {bufferContents = bufferContents,
732	closeAtExit = closeAtExit,
733	closed = false,
734	reader = reader}
735	end
736
737	val newIn = fn (fd, name) =>
738	newIn {bufferContents = NONE,
739	closeAtExit = true,
740	fd = fd,
741	name = name}
742
743	val stdIn = newIn (PFS.stdin, "<stdin>")
744
745	fun openIn file =
746	protect'
747	("openIn", file, fn () =>
748	let
749	val fd = PFS.openf (file, Posix.IO.O_RDONLY, PFS.O.flags fileTypeFlags)
750	in
751	newIn (fd, file)
752	end)
753
754	end
755
756	signature IMPERATIVE_IO_ARG =
757	sig
758	structure Array: MONO_ARRAY
759	(* structure ArraySlice: MONO_ARRAY_SLICE *)
760	structure StreamIO: STREAM_IO
761	structure Vector: MONO_VECTOR
762	(* structure VectorSlice: MONO_VECTOR_SLICE *)
763	(* sharing type Array.array = ArraySlice.array *)
764	sharing type
765	Array.elem
766	(* = ArraySlice.elem *)
767	= StreamIO.elem
768	= Vector.elem
769	(* = VectorSlice.elem *)
770	sharing type
771	Array.vector
772	(* = ArraySlice.vector *)
773	= Vector.vector
774	(* = VectorSlice.vector *)
775	(* sharing type ArraySlice.vector_slice = VectorSlice.slice *)
776	end
777
778	functor ImperativeIO (S: IMPERATIVE_IO_ARG): IMPERATIVE_IO =
779	struct
780	open S
781
782	structure SIO = StreamIO
783
784	type elem = SIO.elem
785	type vector = SIO.vector
786
787	datatype outstream = Out of SIO.outstream ref
788
789	fun output (Out os, v) = SIO.output (!os, v)
790	fun output1 (Out os, v) = SIO.output1 (!os, v)
791	fun flushOut (Out os) = SIO.flushOut (!os)
792	fun closeOut (Out os) = SIO.closeOut (!os)
793	fun mkOutstream os = Out (ref os)
794	fun getOutstream (Out os) = !os
795	fun setOutstream (Out os, os') = os := os'
796	fun getPosOut (Out os) = SIO.getPosOut (!os)
797	fun setPosOut (Out os, out_pos) = os := SIO.setPosOut out_pos
798
799	datatype instream = In of SIO.instream ref
800
801	fun canInput (In is, n) = SIO.canInput (!is, n)
802	fun closeIn (In is) = SIO.closeIn (!is)
803	fun endOfStream (In is) = SIO.endOfStream (!is)
804	fun getInstream (In is) = !is
805	fun input (In is) = let val (v, is') = SIO.input (!is)
806	in is := is'; v
807	end
808	(* input1 will never move past a temporary end of stream *)
809	fun input1 (In is) =
810	case SIO.input1 (!is) of
811	SOME (c,is') => (is := is'; SOME c)
812	\| NONE => NONE
813	fun inputAll (In is) = let val (v, is') = SIO.inputAll (!is)
814	in is := is'; v
815	end
816	fun inputN (In is, n) = let val (v, is') = SIO.inputN (!is, n)
817	in is := is'; v
818	end
819	fun lookahead (In is) =
820	Option.map #1 (SIO.input1 (!is))
821	fun mkInstream is = In (ref is)
822	fun setInstream (In is, is') = is := is'
823	end