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/compiler/PervEnv/IO/prim-io-fn.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/PervEnv/IO/prim-io-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 17 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/PervEnv/IO/prim-io-fn.sml

1 : monnier 16 (* prim-io-fn.sml
2 :     *
3 :     * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :     *
5 :     *)
6 :    
7 :     functor PrimIO (
8 :    
9 :     structure Vector : MONO_VECTOR
10 :     structure Array : MONO_ARRAY
11 :     sharing type Vector.vector = Array.vector
12 :     sharing type Vector.elem = Array.elem
13 :     val someElem : Vector.elem
14 :     eqtype pos
15 :     val compare : (pos * pos) -> order
16 :    
17 :     ) : PRIM_IO = struct
18 :    
19 :     structure A = Array
20 :     structure V = Vector
21 :    
22 :     type elem = A.elem
23 :     type vector = V.vector
24 :     type array = A.array
25 :     type pos = pos
26 :    
27 :     val compare = compare
28 :    
29 :     datatype reader = RD of {
30 :     name : string,
31 :     chunkSize : int,
32 :     readVec : (int -> vector) option,
33 :     readArr : ({buf : array, i : int, sz : int option} -> int) option,
34 :     readVecNB : (int -> vector option) option,
35 :     readArrNB : ({buf : array, i : int, sz : int option} -> int option) option,
36 :     block : (unit -> unit) option,
37 :     canInput : (unit -> bool) option,
38 :     avail : unit -> int option,
39 :     getPos : (unit -> pos) option,
40 :     setPos : (pos -> unit) option,
41 :     endPos : (unit -> pos) option,
42 :     verifyPos : (unit -> pos) option,
43 :     close : unit -> unit,
44 :     ioDesc : OS.IO.iodesc option
45 :     }
46 :    
47 :     datatype writer = WR of {
48 :     name : string,
49 :     chunkSize : int,
50 :     writeVec : ({buf : vector, i : int, sz : int option} -> int) option,
51 :     writeArr : ({buf : array, i : int, sz : int option} -> int) option,
52 :     writeVecNB : ({buf : vector, i : int, sz : int option} -> int option) option,
53 :     writeArrNB : ({buf : array, i : int, sz : int option} -> int option) option,
54 :     block : (unit -> unit) option,
55 :     canOutput : (unit -> bool) option,
56 :     getPos : (unit -> pos) option,
57 :     setPos : (pos -> unit) option,
58 :     endPos : (unit -> pos) option,
59 :     verifyPos : (unit -> pos) option,
60 :     close : unit -> unit,
61 :     ioDesc : OS.IO.iodesc option
62 :     }
63 :    
64 :     fun blockingOperation (f, block) x = (block (); Option.valOf (f x))
65 :    
66 :     fun nonblockingOperation (read, canInput) x =
67 :     if (canInput()) then SOME(read x) else NONE
68 :    
69 :     fun augmentReader (RD rd) = let
70 :     fun readaToReadv reada n = let
71 :     val a = A.array(n, someElem)
72 :     val n = reada{buf=a, i=0, sz=NONE}
73 :     in
74 :     A.extract(a, 0, SOME n)
75 :     end
76 :     fun readaToReadvNB readaNB n = let
77 :     val a = A.array(n, someElem)
78 :     in
79 :     case readaNB{buf=a, i=0, sz=NONE}
80 :     of SOME n' => SOME(A.extract(a, 0, SOME n'))
81 :     | NONE => NONE
82 :     (* end case *)
83 :     end
84 :     fun readvToReada readv {buf, i, sz} = let
85 :     val nelems = (case sz of NONE => A.length buf - i | SOME n => n)
86 :     val v = readv nelems
87 :     val len = V.length v
88 :     in
89 :     A.copyVec {dst=buf, di=i, src=v, si=0, len=NONE};
90 :     len
91 :     end
92 :     fun readvToReadaNB readvNB {buf, i, sz} = let
93 :     val nelems = (case sz of NONE => A.length buf - i | SOME n => n)
94 :     in
95 :     case readvNB nelems
96 :     of SOME v => let
97 :     val len = V.length v
98 :     in
99 :     A.copyVec {dst=buf, di=i, src=v, si=0, len=NONE};
100 :     SOME len
101 :     end
102 :     | NONE => NONE
103 :     (* end case *)
104 :     end
105 :     val readVec' = (case rd
106 :     of {readVec=SOME f, ...} => SOME f
107 :     | {readArr=SOME f, ...} => SOME(readaToReadv f)
108 :     | {readVecNB=SOME f, block=SOME b, ...} =>
109 :     SOME(blockingOperation (f, b))
110 :     | {readArrNB=SOME f, block=SOME b, ...} =>
111 :     SOME(blockingOperation (readaToReadvNB f, b))
112 :     | _ => NONE
113 :     (* end case *))
114 :     val readArr' = (case rd
115 :     of {readArr=SOME f, ...} => SOME f
116 :     | {readVec=SOME f, ...} => SOME(readvToReada f)
117 :     | {readArrNB=SOME f, block=SOME b, ...} =>
118 :     SOME(blockingOperation(f, b))
119 :     | {readVecNB=SOME f,block=SOME b, ...} =>
120 :     SOME(blockingOperation(readvToReadaNB f, b))
121 :     | _ => NONE
122 :     (* end case *))
123 :     val readVecNB' = (case rd
124 :     of {readVecNB=SOME f, ...} => SOME f
125 :     | {readArrNB=SOME f, ...} => SOME(readaToReadvNB f)
126 :     | {readVec=SOME f, canInput=SOME can, ...} =>
127 :     SOME(nonblockingOperation(f, can))
128 :     | {readArr=SOME f, canInput=SOME can, ...} =>
129 :     SOME(nonblockingOperation(readaToReadv f, can))
130 :     | _ => NONE
131 :     (* end case *))
132 :     val readArrNB' = (case rd
133 :     of {readArrNB=SOME f, ...} => SOME f
134 :     | {readVecNB=SOME f, ...} => SOME(readvToReadaNB f)
135 :     | {readArr=SOME f, canInput=SOME can, ...} =>
136 :     SOME(nonblockingOperation (f, can))
137 :     | {readVec=SOME f, canInput=SOME can, ...} =>
138 :     SOME(nonblockingOperation (readvToReada f, can))
139 :     | _ => NONE
140 :     (* end case *))
141 :     in RD{
142 :     name= #name rd, chunkSize= #chunkSize rd,
143 :     readVec=readVec', readArr=readArr',
144 :     readVecNB=readVecNB', readArrNB=readArrNB',
145 :     block= #block rd, canInput = #canInput rd, avail = #avail rd,
146 :     getPos = #getPos rd, setPos = #setPos rd, endPos = #endPos rd,
147 :     verifyPos = #verifyPos rd,
148 :     close= #close rd,
149 :     ioDesc= #ioDesc rd
150 :     }
151 :     end
152 :    
153 :     fun augmentWriter (WR wr) = let
154 :     fun writevToWritea writev {buf, i, sz} = let
155 :     val v = A.extract(buf, i, sz)
156 :     in
157 :     writev{buf=v, i=0, sz=NONE}
158 :     end
159 :     fun writeaToWritev writea {buf, i, sz} = let
160 :     val n = (case sz of NONE => V.length buf - i | (SOME n) => n)
161 :     in
162 :     case n
163 :     of 0 => 0
164 :     | _ => let
165 :     val a = A.array(n, V.sub(buf, i))
166 :     in
167 :     A.copyVec {dst=a, di=1, src=buf, si=i+1, len=SOME(n-1)};
168 :     writea {buf=a, i=0, sz=NONE}
169 :     end
170 :     (* end case *)
171 :     end
172 :     fun writeaToWritevNB writeaNB {buf, i, sz} = let
173 :     val n = (case sz of NONE => V.length buf - i | (SOME n) => n)
174 :     in
175 :     case n
176 :     of 0 => SOME 0
177 :     | _ => let
178 :     val a = A.array(n, V.sub(buf, i))
179 :     in
180 :     A.copyVec {dst=a, di=1, src=buf, si=i+1, len=SOME(n-1)};
181 :     writeaNB {buf=a, i=0, sz=NONE}
182 :     end
183 :     (* end case *)
184 :     end
185 :     val writeVec' = (case wr
186 :     of {writeVec=SOME f, ...} => SOME f
187 :     | {writeArr=SOME f, ...} => SOME(writeaToWritev f)
188 :     | {writeVecNB=SOME f, block=SOME b, ...} =>
189 :     SOME(fn i => (b(); Option.valOf(f i)))
190 :     | {writeArrNB=SOME f, block=SOME b, ...} =>
191 :     SOME(fn x => (b(); writeaToWritev (Option.valOf o f) x))
192 :     | _ => NONE
193 :     (* end case *))
194 :     val writeArr' = (case wr
195 :     of {writeArr=SOME f, ...} => SOME f
196 :     | {writeVec=SOME f, ...} => SOME(writevToWritea f)
197 :     | {writeArrNB=SOME f, block=SOME b, ...} => SOME(blockingOperation (f, b))
198 :     | {writeVecNB=SOME f,block=SOME b, ...} =>
199 :     SOME(blockingOperation (writevToWritea f, b))
200 :     | _ => NONE
201 :     (* end case *))
202 :     val writeVecNB' = (case wr
203 :     of {writeVecNB=SOME f, ...} => SOME f
204 :     | {writeArrNB=SOME f, ...} => SOME(writeaToWritevNB f)
205 :     | {writeVec=SOME f, canOutput=SOME can, ...} =>
206 :     SOME(nonblockingOperation (f, can))
207 :     | {writeArr=SOME f, canOutput=SOME can, ...} =>
208 :     SOME(nonblockingOperation (writeaToWritev f, can))
209 :     | _ => NONE
210 :     (* end case *))
211 :     val writeArrNB' = (case wr
212 :     of {writeArrNB=SOME f, ...} => SOME f
213 :     | {writeVecNB=SOME f, ...} => SOME(writevToWritea f)
214 :     | {writeArr=SOME f, canOutput=SOME can, ...} =>
215 :     SOME(nonblockingOperation (f, can))
216 :     | {writeVec=SOME f, canOutput=SOME can, ...} =>
217 :     SOME(nonblockingOperation (writevToWritea f, can))
218 :     | _ => NONE
219 :     (* end case *))
220 :     in WR{
221 :     name= #name wr, chunkSize= #chunkSize wr,
222 :     writeVec=writeVec', writeArr=writeArr',
223 :     writeVecNB=writeVecNB', writeArrNB=writeArrNB',
224 :     block= #block wr, canOutput = #canOutput wr,
225 :     getPos = #getPos wr, setPos = #setPos wr, endPos = #endPos wr,
226 :     verifyPos = #verifyPos wr,
227 :     close= #close wr,
228 :     ioDesc= #ioDesc wr
229 :     }
230 :     end
231 :    
232 :     end (* PrimIO *)
233 :    
234 :    
235 :     (*
236 :     * $Log: prim-io-fn.sml,v $
237 :     * Revision 1.2 1997/02/26 21:00:25 george
238 :     * Defined a new top level Option structure. All 'a option related
239 :     * functions have been moved out of General.
240 :     *
241 :     * Revision 1.1.1.1 1997/01/14 01:38:19 george
242 :     * Version 109.24
243 :     *
244 :     *)

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