bin-io-fn.sml

来自「这是我们参加06年全国开源软件的竞赛作品」· SML 代码 · 共 714 行 · 第 1/2 页

	fun getReader (ISTRM(buf, pos)) = let
	      val IBUF{data, info as INFO{reader, ...}, more, ...} = buf
	      fun getData more = (case SV.mGet more
		     of (MORE(IBUF{data, more=more', ...})) => data :: getData more'
		      | _ => []
		    (* end case *))
	      in
		terminate info;
		if (pos < V.length data)
		  then (
		      reader,
		      V.concat(vecExtract(data, pos, NONE) :: getData more)
		    )
		  else (reader, V.concat(getData more))
	      end

      (** Position operations on instreams **)
	datatype in_pos = INP of {
	    base : pos,
	    offset : int,
	    info : info
	  }

	fun getPosIn (ISTRM(buf, pos)) = (case buf
	       of IBUF{basePos=NONE, info, ...} =>
		    inputExn (info, "getPosIn", IO.RandomAccessNotSupported)
		| IBUF{basePos=SOME p, info, ...} => INP{
		      base = p, offset = pos, info = info
		    }
	      (* end case *))
	fun filePosIn (INP{base, offset, ...}) =
	      Position.+(base, Position.fromInt offset)
	fun setPosIn (pos as INP{info as INFO{reader, ...}, ...}) = let
	      val fpos = filePosIn pos
	      val (PIO.RD rd) = reader
	      in
		terminate info;
		valOf (#setPos rd) fpos;
		mkInstream (PIO.RD rd, NONE)
	      end


      (*** Output streams ***)

      (* an output stream is implemented as a monitor using an mvar to
       * hold its data.
       *)

	datatype ostrm_info = OSTRM of {
	    buf : A.array,
	    pos : int ref,
	    closed : bool ref,
	    bufferMode : IO.buffer_mode ref,
	    writer : writer,
	    writeArr : {buf : A.array, i : int, sz : int option} -> unit,
	    writeVec : {buf : V.vector, i : int, sz : int option} -> unit,
	    cleanTag : CleanIO.tag
	  }

	type outstream = ostrm_info SV.mvar

	fun outputExn (OSTRM{writer=PIO.WR{name, ...}, ...}, mlOp, exn) =
	      raise IO.Io{function=mlOp, name=name, cause=exn}

      (* lock access to the stream and make sure that it is not closed. *)
	fun lockAndChkClosedOut (strmMV, mlOp) = (case SV.mTake strmMV
	       of (strm as OSTRM({closed=ref true, ...})) => (
		    SV.mPut (strmMV, strm);
		    outputExn (strm, mlOp, IO.ClosedStream))
		| strm => strm
	      (* end case *))

	fun flushBuffer (strmMV, strm as OSTRM{buf, pos, writeArr, ...}, mlOp) = (
	      case !pos
	       of 0 => ()
		| n => ((
		    writeArr {buf=buf, i=0, sz=SOME n}; pos := 0)
		      handle ex => (
			SV.mPut(strmMV, strm); outputExn (strm, mlOp, ex)))
	      (* end case *))

	fun output (strmMV, v) = let
	      val (strm as OSTRM os) = lockAndChkClosedOut (strmMV, "output")
	      fun release () = SV.mPut (strmMV, strm)
	      val {buf, pos, bufferMode, ...} = os
	      fun flush () = flushBuffer (strmMV, strm, "output")
	      fun flushAll () = (#writeArr os {buf=buf, i=0, sz=NONE}
		    handle ex => (release(); outputExn (strm, "output", ex)))
	      fun writeDirect () = (
		    case !pos
		     of 0 => ()
		      | n => (#writeArr os {buf=buf, i=0, sz=SOME n}; pos := 0)
		    (* end case *);
		    #writeVec os {buf=v, i=0, sz=NONE})
		      handle ex => (release(); outputExn (strm, "output", ex))
	      fun insert copyVec = let
		    val bufLen = A.length buf
		    val dataLen = V.length v
		    in
		      if (dataLen >= bufLen)
			then writeDirect()
			else let
			  val i = !pos
			  val avail = bufLen - i
			  in
			    if (avail < dataLen)
			      then (
				copyVec(v, 0, avail, buf, i);
				flushAll();
				copyVec(v, avail, dataLen-avail, buf, 0);
			  	pos := dataLen-avail)
			    else (
			      copyVec(v, 0, dataLen, buf, i);
			      pos := i + dataLen;
			      if (avail = dataLen) then flush() else ())
			  end
		    end
	      in
		case !bufferMode
		 of IO.NO_BUF => writeDirect ()
		  | _ => let
		      fun copyVec (src, srcI, srcLen, dst, dstI) = A.copyVec {
			      src = src, si = srcI, len = SOME srcLen,
			      dst = dst, di = dstI
			    }
		      in
			insert copyVec
		      end
		(* end case *);
		release()
	      end

	fun output1 (strmMV, elem) = let
	      val (strm as OSTRM{buf, pos, bufferMode, writeArr, ...}) =
		    lockAndChkClosedOut (strmMV, "output1")
	      fun release () = SV.mPut (strmMV, strm)
	      in
		case !bufferMode
		 of IO.NO_BUF => (
		      arrUpdate (buf, 0, elem);
		      writeArr {buf=buf, i=0, sz=SOME 1}
			handle ex => (release(); outputExn (strm, "output1", ex)))
		  | _ => let val i = !pos val i' = i+1
		      in
			arrUpdate (buf, i, elem); pos := i';
			if (i' = A.length buf)
			  then flushBuffer (strmMV, strm, "output1")
			  else ()
		      end
		(* end case *);
		release()
	      end

	fun flushOut strmMV = let
	      val strm = lockAndChkClosedOut (strmMV, "flushOut")
	      in
		flushBuffer (strmMV, strm, "flushOut");
		SV.mPut (strmMV, strm)
	      end

	fun closeOut strmMV = let
	      val (strm as OSTRM{writer=PIO.WR{close, ...}, closed, cleanTag, ...}) =
		    SV.mTake strmMV
	      in
		if !closed
		  then ()
		  else (
		    flushBuffer (strmMV, strm, "closeOut");
		    closed := true;
		    CleanIO.removeCleaner cleanTag;
		    close());
		SV.mPut (strmMV, strm)
	      end

	fun mkOutstream (wr as PIO.WR{chunkSize, writeArr, writeVec, ...}, mode) =
	      let
	      fun iterate f (buf, i, sz) = let
		    fun lp (_, 0) = ()
		      | lp (i, n) = let val n' = f{buf=buf, i=i, sz=SOME n}
			  in lp (i+n', n-n') end
		    in
		      lp (i, sz)
		    end
	      fun writeArr' {buf, i, sz} = let
		    val len = (case sz
			   of NONE => A.length buf - i
			    | (SOME n) => n
			  (* end case *))
		    in
		      iterate writeArr (buf, i, len)
		    end
	      fun writeVec' {buf, i, sz} = let
		    val len = (case sz
			   of NONE => V.length buf - i
			    | (SOME n) => n
			  (* end case *))
		    in
		      iterate writeVec (buf, i, len)
		    end
	    (* install a dummy cleaner *)
	      val tag = CleanIO.addCleaner dummyCleaner
	      val strm = SV.mVarInit (OSTRM{
		      buf = A.array(chunkSize, someElem),
		      pos = ref 0,
		      closed = ref false,
		      bufferMode = ref mode,
		      writer = wr,
		      writeArr = writeArr',
		      writeVec = writeVec',
		      cleanTag = tag
		    })
	      in
		CleanIO.rebindCleaner (tag, fn () => closeOut strm);
		strm
	      end

	fun getWriter strmMV = let
	      val (strm as OSTRM{writer, bufferMode, ...}) =
		    lockAndChkClosedOut (strmMV, "getWriter")
	      in
		(writer, !bufferMode) before SV.mPut(strmMV, strm)
	      end

      (** Position operations on outstreams **)
	datatype out_pos = OUTP of {
	    pos : PIO.pos,
	    strm : outstream
	  }

	fun getPosOut strmMV = let
	      val (strm as OSTRM{writer, ...}) =
		    lockAndChkClosedOut (strmMV, "getWriter")
	      fun release () = SV.mPut(strmMV, strm)
	      in
		flushBuffer (strmMV, strm, "getPosOut");
		case writer
	 	 of PIO.WR{getPos=SOME f, ...} => (
		      OUTP{pos = f(), strm = strmMV}
		        handle ex => (release(); outputExn(strm, "getPosOut", ex)))
		  | _ => (
		      release();
		      outputExn(strm, "getPosOut", IO.RandomAccessNotSupported))
		(* end case *)
		before release()
	      end
	fun filePosOut (OUTP{pos, strm=strmMV}) = (
	      SV.mPut (strmMV, lockAndChkClosedOut (strmMV, "filePosOut"));
	      pos)
	fun setPosOut (OUTP{pos, strm=strmMV}) = let
	      val (strm as OSTRM{writer, ...}) =
		    lockAndChkClosedOut (strmMV, "setPosOut")
	      fun release () = SV.mPut(strmMV, strm)
	      in
		case writer
		 of PIO.WR{setPos=SOME f, ...} => (
		      (f pos)
			handle ex => (release(); outputExn(strm, "setPosOut", ex)))
		  | _ => (
		      release();
		      outputExn(strm, "getPosOut", IO.RandomAccessNotSupported))
		(* end case *);
		release()
	      end

	fun setBufferMode (strmMV, mode) = let
	      val (strm as OSTRM{bufferMode, ...}) =
		    lockAndChkClosedOut (strmMV, "setBufferMode")
	      in
		if (mode = IO.NO_BUF)
		  then flushBuffer (strmMV, strm, "setBufferMode")
		  else ();
		bufferMode := mode;
		SV.mPut (strmMV, strm)
	      end
	fun getBufferMode strmMV = let
(** should we be checking for closed streams here??? **)
	      val (strm as OSTRM{bufferMode, ...}) =
		    lockAndChkClosedOut (strmMV, "getBufferMode")
	      in
		!bufferMode before SV.mPut (strmMV, strm)
	      end

      end (* StreamIO *)

    type vector = V.vector
    type elem = V.elem
    type instream = StreamIO.instream SV.mvar
    type outstream = StreamIO.outstream SV.mvar

  (** Input operations **)
    fun input strm = let val (v, strm') = StreamIO.input(SV.mTake strm)
	  in
	    SV.mPut (strm, strm'); v
	  end
    fun input1 strm = (case StreamIO.input1(SV.mTake strm)
	   of NONE => NONE
	    | (SOME(elem, strm')) => (SV.mPut (strm, strm'); SOME elem)
	  (* end case *))
    fun inputN (strm, n) = let val (v, strm') = StreamIO.inputN (SV.mTake strm, n)
	  in
	    SV.mPut (strm, strm'); v
	  end
    fun inputAll (strm : instream) = let
	  val (v, strm') = StreamIO.inputAll(SV.mTake strm)
	  in
	    SV.mPut (strm, strm'); v
	  end
    fun input1Evt _ = raise Fail "input1Evt unimplemented"
    fun inputEvt _ = raise Fail "inputEvt unimplemented"
    fun inputNEvt _ = raise Fail "inputNEvt unimplemented"
    fun inputAllEvt _ = raise Fail "inputAllEvt unimplemented"
    fun canInput (strm, n) = StreamIO.canInput (SV.mGet strm, n)
    fun lookahead (strm : instream) = (case StreamIO.input1(SV.mGet strm)
	   of NONE => NONE
	    | (SOME(elem, _)) => SOME elem
	  (* end case *))
    fun closeIn strm = let
	  val (s as StreamIO.ISTRM(buf as StreamIO.IBUF{data, ...}, _)) =
		SV.mTake strm
	  in
	    StreamIO.closeIn s;
	    SV.mPut(strm, StreamIO.findEOS buf)
	  end
    fun endOfStream strm = StreamIO.endOfStream(SV.mGet strm)
    fun getPosIn strm = StreamIO.getPosIn(SV.mGet strm)
    fun setPosIn (strm, p) = mUpdate(strm, StreamIO.setPosIn p)

  (** Output operations **)
    fun output (strm, v) = StreamIO.output(SV.mGet strm, v)
    fun output1 (strm, c) = StreamIO.output1(SV.mGet strm, c)
    fun flushOut strm = StreamIO.flushOut(SV.mGet strm)
    fun closeOut strm = StreamIO.closeOut(SV.mGet strm)
    fun getPosOut strm = StreamIO.getPosOut(SV.mGet strm)
    fun setPosOut (strm, p as StreamIO.OUTP{strm=strm', ...}) = (
	  mUpdate(strm, strm'); StreamIO.setPosOut p)

    fun mkInstream (strm : StreamIO.instream) = SV.mVarInit strm
    fun getInstream (strm : instream) = SV.mGet strm
    fun setInstream (strm : instream, strm') = mUpdate(strm, strm')

    fun mkOutstream (strm : StreamIO.outstream) = SV.mVarInit strm
    fun getOutstream (strm : outstream) = SV.mGet strm
    fun setOutstream (strm : outstream, strm') = mUpdate(strm, strm')

  (** Open files **)
    fun openIn fname =
	  mkInstream(StreamIO.mkInstream(OSPrimIO.openRd fname, NONE))
	    handle ex => raise IO.Io{function="openIn", name=fname, cause=ex}
    fun openOut fname =
	  mkOutstream(StreamIO.mkOutstream(OSPrimIO.openWr fname, IO.BLOCK_BUF))
	    handle ex => raise IO.Io{function="openOut", name=fname, cause=ex}
    fun openAppend fname =
	  mkOutstream(StreamIO.mkOutstream(OSPrimIO.openApp fname, IO.NO_BUF))
	    handle ex => raise IO.Io{function="openAppend", name=fname, cause=ex}

  end (* BinIOFn *)