Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] View of /sml/branches/idlbasis-devel/src/system/Basis/Implementation/IO/prim-io-fn.sml
ViewVC logotype

View of /sml/branches/idlbasis-devel/src/system/Basis/Implementation/IO/prim-io-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 866 - (download) (annotate)
Mon Jul 2 16:33:10 2001 UTC (19 years, 5 months ago) by blume
File size: 9253 byte(s)
more fixup work
(* prim-io-fn.sml
 *
 * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
 *
 *)

functor PrimIO (

    structure Vector : MONO_VECTOR
    structure Array : MONO_ARRAY
    structure ArraySlice : MONO_ARRAY_SLICE
    structure VectorSlice : MONO_VECTOR_SLICE
      sharing type Vector.vector = Array.vector = ArraySlice.vector = VectorSlice.vector
      sharing type Vector.elem = Array.elem = ArraySlice.elem = VectorSlice.elem
      sharing type Array.array = ArraySlice.array
      sharing type ArraySlice.vector_slice = VectorSlice.slice
    val someElem : Vector.elem

    eqtype pos
    val compare : (pos * pos) -> order
  ) : PRIM_IO = struct

    structure A = Array
    structure V = Vector
    structure AS = ArraySlice
    structure VS = VectorSlice

    type elem = A.elem
    type vector = V.vector
    type array = A.array
    type pos = pos

    val compare = compare

    datatype reader = RD of {
	name      : string,
	chunkSize : int,
	readVec   : (int -> vector) option,
        readArr   : ({buf : array, i : int, sz : int option} -> int) option,
	readVecNB : (int -> vector option) option,
	readArrNB : ({buf : array, i : int, sz : int option} -> int option) option,
	block     : (unit -> unit) option,
	canInput  : (unit -> bool) option,
	avail     : unit -> int option,
	getPos    : (unit -> pos) option,
	setPos    : (pos -> unit) option,
        endPos    : (unit -> pos) option,
	verifyPos : (unit -> pos) option,
	close     : unit -> unit,
	ioDesc    : OS.IO.iodesc option
      }

    datatype writer = WR of {
	name       : string,
	chunkSize  : int,
	writeVec   : ({buf : vector, i : int, sz : int option} -> int) option,
	writeArr   : ({buf : array, i : int, sz : int option} -> int) option,
	writeVecNB : ({buf : vector, i : int, sz : int option} -> int option) option,
	writeArrNB : ({buf : array, i : int, sz : int option} -> int option) option,
	block      : (unit -> unit) option,
	canOutput  : (unit -> bool) option,
	getPos     : (unit -> pos) option,
	setPos     : (pos -> unit) option,
        endPos     : (unit -> pos) option,
	verifyPos  : (unit -> pos) option,
	close      : unit -> unit,
	ioDesc     : OS.IO.iodesc option
      }

    fun blockingOperation (f, block) x = (block (); Option.valOf (f x))

    fun nonblockingOperation (read, canInput) x =
	  if (canInput()) then SOME(read x) else NONE

    fun augmentReader (RD rd) = let
	  fun readaToReadv reada n = let
		val a = A.array(n, someElem)
		val n = reada{buf=a, i=0, sz=NONE}
		in
	            AS.vector (AS.slice (a, 0, SOME n))
		end
	  fun readaToReadvNB readaNB n = let
		val a = A.array(n, someElem)
		in
		  case readaNB{buf=a, i=0, sz=NONE}
		   of SOME n' => SOME(AS.vector (AS.slice (a, 0, SOME n')))
		    | NONE => NONE  
		  (* end case *)
		end
	  fun readvToReada readv {buf, i, sz} = let
		val nelems = (case sz of NONE => A.length buf - i | SOME n => n)
		val v = readv nelems
		val len = V.length v
		in
		  A.copyVec {dst=buf, di=i, src=v};
		  len
		end
	  fun readvToReadaNB readvNB {buf, i, sz} = let
		val nelems = (case sz of NONE => A.length buf - i | SOME n => n)
		in
		  case readvNB nelems
		   of SOME v => let
			val len = V.length v
			in
			  A.copyVec {dst=buf, di=i, src=v};
			  SOME len
			end
		    | NONE => NONE
		  (* end case *)
		end
	  val readVec' = (case rd
		 of {readVec=SOME f, ...} => SOME f
		  | {readArr=SOME f, ...} => SOME(readaToReadv f)
		  | {readVecNB=SOME f, block=SOME b, ...} =>
		      SOME(blockingOperation (f, b))
		  | {readArrNB=SOME f, block=SOME b, ...} =>
		      SOME(blockingOperation (readaToReadvNB f, b))
		  | _ => NONE
		(* end case *))
	  val readArr' = (case rd
		 of {readArr=SOME f, ...} => SOME f
		  | {readVec=SOME f, ...} => SOME(readvToReada f)
		  | {readArrNB=SOME f, block=SOME b, ...} =>
		      SOME(blockingOperation(f, b))
		  | {readVecNB=SOME f,block=SOME b, ...} =>
		      SOME(blockingOperation(readvToReadaNB f, b))
		  | _ => NONE
		(* end case *))
	  val readVecNB' = (case rd
		 of {readVecNB=SOME f, ...} => SOME f
		  | {readArrNB=SOME f, ...} => SOME(readaToReadvNB f)
		  | {readVec=SOME f, canInput=SOME can, ...} =>
		      SOME(nonblockingOperation(f, can))
		  | {readArr=SOME f, canInput=SOME can, ...} =>
		      SOME(nonblockingOperation(readaToReadv f, can))
		  | _ => NONE
		(* end case *))
	  val readArrNB' = (case rd
		 of {readArrNB=SOME f, ...} => SOME f
		  | {readVecNB=SOME f, ...} => SOME(readvToReadaNB f)
		  | {readArr=SOME f, canInput=SOME can, ...} =>
		      SOME(nonblockingOperation (f, can))
		  | {readVec=SOME f, canInput=SOME can, ...} =>
		      SOME(nonblockingOperation (readvToReada f, can))
		  | _ => NONE
		(* end case *))
	  in RD{
	      name= #name rd, chunkSize= #chunkSize rd,
	      readVec=readVec', readArr=readArr',
	      readVecNB=readVecNB', readArrNB=readArrNB',
	      block= #block rd, canInput = #canInput rd, avail = #avail rd,
	      getPos = #getPos rd, setPos = #setPos rd, endPos = #endPos rd, 
	      verifyPos = #verifyPos rd,
	      close= #close rd,
	      ioDesc= #ioDesc rd
	    }
	  end

    fun augmentWriter (WR wr) = let
	  fun writevToWritea writev {buf, i, sz} = let
		val v = AS.vector (AS.slice(buf, i, sz))
		in
		  writev{buf=v, i=0, sz=NONE}
		end
	  fun writeaToWritev writea {buf, i, sz} = let
		val n = (case sz of NONE => V.length buf - i | (SOME n) => n)
		in
		  case n
		   of 0 => 0
		    | _ => let
			val a = A.array(n, V.sub(buf, i))
			in
			  AS.copyVec {dst=a, di=1, src=VS.slice(buf,i+1,SOME(n-1))};
			  writea {buf=a, i=0, sz=NONE}
			end
		  (* end case *)
		end
	  fun writeaToWritevNB writeaNB {buf, i, sz} = let
		val n = (case sz of NONE => V.length buf - i | (SOME n) => n)
		in
		  case n
		   of 0 => SOME 0
		    | _ => let
			val a = A.array(n, V.sub(buf, i))
			in
			  AS.copyVec {dst=a, di=1, src=VS.slice(buf,i+1,SOME(n-1))};
			  writeaNB {buf=a, i=0, sz=NONE}
			end
		  (* end case *)
		end
	  val writeVec' = (case wr
		 of {writeVec=SOME f, ...} => SOME f
		  | {writeArr=SOME f, ...} => SOME(writeaToWritev f)
		  | {writeVecNB=SOME f, block=SOME b, ...} => 
		      SOME(fn i => (b(); Option.valOf(f i)))
		  | {writeArrNB=SOME f, block=SOME b, ...} =>
		      SOME(fn x => (b(); writeaToWritev (Option.valOf o f) x))
		  | _ => NONE
		(* end case *))
	  val writeArr' = (case wr
		 of {writeArr=SOME f, ...} => SOME f
		  | {writeVec=SOME f, ...} => SOME(writevToWritea f)
		  | {writeArrNB=SOME f, block=SOME b, ...} => SOME(blockingOperation (f, b))
		  | {writeVecNB=SOME f,block=SOME b, ...} =>
		      SOME(blockingOperation (writevToWritea f, b))
		  | _ => NONE
		(* end case *))
	  val writeVecNB' = (case wr
		 of {writeVecNB=SOME f, ...} => SOME f
		  | {writeArrNB=SOME f, ...} => SOME(writeaToWritevNB f)
		  | {writeVec=SOME f, canOutput=SOME can, ...} =>
		      SOME(nonblockingOperation (f, can))
		  | {writeArr=SOME f, canOutput=SOME can, ...} =>
		      SOME(nonblockingOperation (writeaToWritev f, can))
		  | _ => NONE
		(* end case *))
	  val writeArrNB' = (case wr
		 of {writeArrNB=SOME f, ...} => SOME f
		  | {writeVecNB=SOME f, ...} => SOME(writevToWritea f)
		  | {writeArr=SOME f, canOutput=SOME can, ...} =>
		      SOME(nonblockingOperation (f, can))
		  | {writeVec=SOME f, canOutput=SOME can, ...} =>
		      SOME(nonblockingOperation (writevToWritea f, can))
		  | _ => NONE
		(* end case *))
	  in WR{
	      name= #name wr, chunkSize= #chunkSize wr,
	      writeVec=writeVec', writeArr=writeArr',
	      writeVecNB=writeVecNB', writeArrNB=writeArrNB',
	      block= #block wr, canOutput = #canOutput wr,
	      getPos = #getPos wr, setPos = #setPos wr, endPos = #endPos wr,
	      verifyPos = #verifyPos wr,
	      close= #close wr,
	      ioDesc= #ioDesc wr
	    }
	  end

(*
    fun openVector v = let
	val len = V.length v
	val pos = ref 0
	val closed = ref false
	fun checkClosed () = if !closed then raise IO.ClosedStream else ()
	fun avail () = len - !pos
	fun readV n = let
	    val p = !pos
	    val m = Int.min (n, len - p)
	in
	    checkClosed ();
	    pos := p + m;
	    VS.vector (VS.slice (src, p, SOME m))
	end
	fun readA { buf, i, sz } = let
	    val p = !pos
	    val m = case sz of
			NONE => Int.min (A.length buf - i, len - p)
		      | SOME n => Int.min (n, len - p)
	in
	    checkClosed ();
	    pos := p + m;
	    A.copyVec { dst = buf, di = i, src = VS.slice (src, p, SOME m) };
	    m
	end
	fun getPos () = (checkClosed (); !pos)
	fun setPos i =
	    (checkClosed ();
	     if i < 0 orelse len < i then raise Subscript else ();
	     pos := i)
    in
	RD { name = "<vector>",
	     chunkSize = len,
	     readVec = SOME readV,
	     readArr = SOME readA,
	     readVecNB = SOME (SOME o readV),
	     readArrNB = SOME (SOME o readA),
	     block = SOME checkClosed,
	     canInput = SOME (fn () => (checkClosed (); true)),
	     avail = SOME o avail,
	     getPos = SOME getPos,
	     setPos = SOME setPos,
	     endPos = SOME (fn () => (checkClosed (); len)),
	     verifyPos = SOME getPos,
	     close = fn () => closed := true,
	     ioDesc = NONE }
    end
*)
    fun openVector v = raise Fail "openVector not implemented yet"
    fun nullRd () = raise Fail "nullRd not implemented yet"
    fun nullWr () = raise Fail "nullWr not implemented yet"

  end (* PrimIO *)

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