text-io-fn.sml

这是我们参加06年全国开源软件的竞赛作品

		(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

      (** Text stream specific operations **)
	fun outputSubstr (strmMV, ss) = let
	      val (strm as OSTRM os) = lockAndChkClosedOut (strmMV, "outputSubstr")
	      fun release () = SV.mPut (strmMV, strm)
	      val (v, dataStart, dataLen) = substringBase ss
	      val {buf, pos, bufferMode, ...} = os
	      val bufLen = A.length buf
	      fun flush () = flushBuffer (strmMV, strm, "outputSubstr")
	      fun flushAll () = (#writeArr os {buf=buf, i=0, sz=NONE}
		    handle ex => (release(); outputExn (strm, "outputSubstr", 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=dataStart, sz=SOME dataLen})
		      handle ex => (release(); outputExn (strm, "outputSubstr", 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 let
				val _ = A.copyVec{
					src=v, si=dataStart, len=SOME avail,
					dst=buf, di=i
				      }
				val _ = flushAll()
				val needsFlush = copyVec(v, avail, dataLen-avail, buf, 0)
				in
			  	  pos := dataLen-avail;
				  if needsFlush then flush () else ()
				end
			    else let
			      val needsFlush = copyVec(v, dataStart, dataLen, buf, i)
			      in
			        pos := i + dataLen;
			        if (needsFlush orelse (avail = dataLen))
				  then flush()
				  else ()
			      end
			  end
		    end
	      in
		case !bufferMode
		 of IO.NO_BUF => writeDirect ()
		  | IO.LINE_BUF => insert lineBufCopyVec
		  | IO.BLOCK_BUF => insert blockBufCopyVec
		(* end case *);
		release()
	      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

  (* event-value constructors *)
    local
      datatype 'a result = RES of 'a | EXN of exn
      fun sendEvt (ch, v) = CML.sendEvt(ch, RES v)
      fun sendExnEvt (ch, exn) = CML.sendEvt(ch, EXN exn)
      fun recvEvt ch =
	    CML.wrap(CML.recvEvt ch, fn (RES v) => v | (EXN exn) => raise exn)
      fun doInput inputEvt (strm : instream) nack = let
	    val replyCh = CML.channel()
	    fun inputThread () = let
		  val strm' = SV.mTake strm
		  val nackEvt = CML.wrap(nack, fn _ => SV.mPut(strm, strm'))
		  fun handleInput (result, strm'') = CML.select [
			  CML.wrap (sendEvt(replyCh, result),
			    fn _ => SV.mPut(strm, strm'')),
			  nackEvt
			]
		  in
		    (CML.select [
			CML.wrap (inputEvt strm', handleInput),
			nackEvt
		      ]) handle exn => CML.select [
			  CML.wrap (sendExnEvt(replyCh, exn),
			    fn _ => SV.mPut(strm, strm')),
			  nackEvt
			]
		  end
	    in
	      ignore (CML.spawn inputThread);
	      recvEvt replyCh
	    end
    in
    fun input1Evt (strm : instream) = let
	  fun inputEvt (strm : StreamIO.instream) = CML.wrap (
		StreamIO.input1Evt strm,
		fn NONE => (NONE, strm) | SOME(s, strm') => (SOME s, strm'))
	  in
	    CML.withNack (doInput inputEvt strm)
	  end
    fun inputEvt strm = CML.withNack (doInput StreamIO.inputEvt strm)
    fun inputNEvt (strm, n) =
	  CML.withNack (doInput (fn strm' => StreamIO.inputNEvt(strm', n)) strm)
    fun inputAllEvt Strm = CML.withNack (doInput StreamIO.inputAllEvt Strm)
    end (* local *)

    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')
 
  (* figure out the proper buffering mode for a given writer *)
    fun bufferMode (PIO.WR{ioDesc=NONE, ...}) = IO.BLOCK_BUF
      | bufferMode (PIO.WR{ioDesc=SOME iod, ...}) =
	  if (OS.IO.kind iod = OS.IO.Kind.tty) then IO.LINE_BUF else IO.BLOCK_BUF

  (** 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 = let
	  val wr = OSPrimIO.openWr fname
	  in
	    mkOutstream(StreamIO.mkOutstream(wr, bufferMode wr))
	      handle ex => raise IO.Io{function="openOut", name=fname, cause=ex}
	  end
    fun openAppend fname =
	  mkOutstream(StreamIO.mkOutstream(OSPrimIO.openApp fname, IO.NO_BUF))
	    handle ex => raise IO.Io{function="openAppend", name=fname, cause=ex}

  (** Text stream specific operations **)
    fun inputLine strm = let val (s, strm') = StreamIO.inputLine (SV.mTake strm)
	  in
	    SV.mPut(strm, strm'); s
	  end
    fun outputSubstr (strm, ss) = StreamIO.outputSubstr (SV.mGet strm, ss)
    fun openString src =
	  mkInstream(StreamIO.mkInstream(OSPrimIO.strReader src, NONE))
	    handle ex => raise IO.Io{function="openIn", name="<string>", cause=ex}

    structure ChanIO = ChanIOFn(
      structure PrimIO = PIO
      structure V = CharVector
      structure A = CharArray)

  (* open an instream that is connected to the output port of a channel. *)
    fun openChanIn ch =
	  mkInstream(StreamIO.mkInstream(ChanIO.mkReader ch, NONE))

  (* open an outstream that is connected to the input port of a channel. *)
    fun openChanOut ch =
	  mkOutstream(StreamIO.mkOutstream(ChanIO.mkWriter ch, IO.NO_BUF))

  (** Standard streams **)
    local
      structure SIO = StreamIO
      fun mkStdIn rebind = let
	    val (tag, strm) = SIO.mkInstream'(OSPrimIO.stdIn(), NONE)
	    in
	      if rebind
		then CleanIO.rebindCleaner (tag, dummyCleaner)
		else ();
	      strm
	    end
      fun mkStdOut rebind = let
	    val wr = OSPrimIO.stdOut()
	    val (tag, strm) = SIO.mkOutstream'(wr, bufferMode wr)
	    in
	      if rebind
		then CleanIO.rebindCleaner (tag, fn () => SIO.flushOut strm)
		else ();
	      strm
	    end
      fun mkStdErr rebind = let
	    val (tag, strm) = SIO.mkOutstream'(OSPrimIO.stdErr(), IO.NO_BUF)
	    in
	      if rebind
		then CleanIO.rebindCleaner (tag, fn () => SIO.flushOut strm)
		else ();
	      strm
	    end
    in
  (* build the standard streams.  Since we are not currently running CML, we
   * cannot do the cleaner rebinding here, but that is okay, since these are
   * just place holders.
   *)
    val stdIn = mkInstream(mkStdIn false)
    val stdOut = mkOutstream(mkStdOut false)
    val stdErr = mkOutstream(mkStdErr false)

    fun print s = let val strm' = SV.mTake stdOut
	  in
	    StreamIO.output (strm', s); StreamIO.flushOut strm';
	    SV.mPut(stdOut, strm')
	  end

    fun scanStream scanFn = let
	  val scan = scanFn StreamIO.input1
	  fun doit strm = let
		val instrm = getInstream strm
		in
		  case scan instrm
		   of NONE => NONE
		    | SOME(item, instrm') => (
			setInstream(strm, instrm');
			SOME item)
		  (* end case *)
		end
	  in
	    doit
	  end

  (* Establish a hook function to rebuild the I/O stack *)
    val _ = CleanIO.stdStrmHook := (fn () => (
	  setInstream (stdIn, mkStdIn true);
	  setOutstream (stdOut, mkStdOut true);
	  setOutstream (stdErr, mkStdErr true);
	  SMLofNJ.Internals.prHook := print))
    end (* local *)

  end (* TextIOFn *)