Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* modified from SML/NJ sources by Stephen Weeks 1998-06-25 *) |
2 | (* modified by Matthew Fluet 2002-10-11 *) | |
3 | (* modified by Matthew Fluet 2002-11-21 *) | |
4 | (* modified by Matthew Fluet 2006-04-30 *) | |
5 | (* modified by Matthew Fluet 2008-04-06 *) | |
6 | (* modified by Matthew Fluet 2013-06-18 *) | |
7 | ||
8 | (* os-io.sml | |
9 | * | |
10 | * COPYRIGHT (c) 1995 AT&T Bell Laboratories. | |
11 | * | |
12 | * NOTE: this interface has been proposed, but not yet adopted by the | |
13 | * Standard basis committee. | |
14 | * | |
15 | *) | |
16 | ||
17 | structure OS_IO: OS_IO = | |
18 | struct | |
19 | structure Error = PosixError | |
20 | ||
21 | (* an iodesc is an abstract descriptor for an OS object that | |
22 | * supports I/O (e.g., file, tty device, socket, ...). | |
23 | *) | |
24 | type iodesc = PreOS.IODesc.t | |
25 | ||
26 | datatype iodesc_kind = K of string | |
27 | ||
28 | val iodToFd = PrePosix.FileDesc.fromRep o PreOS.IODesc.toRep | |
29 | val fdToIod = PreOS.IODesc.fromRep o PrePosix.FileDesc.toRep | |
30 | ||
31 | val iodescToWord = C_Fd.castToSysWord o PreOS.IODesc.toRep | |
32 | ||
33 | (* return a hash value for the I/O descriptor. *) | |
34 | val hash = SysWord.toWord o iodescToWord | |
35 | ||
36 | (* compare two I/O descriptors *) | |
37 | fun compare (i, i') = SysWord.compare (iodescToWord i, iodescToWord i') | |
38 | ||
39 | structure Kind = | |
40 | struct | |
41 | val file = K "FILE" | |
42 | val dir = K "DIR" | |
43 | val symlink = K "LINK" | |
44 | val tty = K "TTY" | |
45 | val pipe = K "PIPE" | |
46 | val socket = K "SOCK" | |
47 | val device = K "DEV" | |
48 | end | |
49 | ||
50 | (* return the kind of I/O descriptor *) | |
51 | fun kind (iod) = let | |
52 | val stat = Posix.FileSys.fstat (iodToFd iod) | |
53 | in | |
54 | if (Posix.FileSys.ST.isReg stat) then Kind.file | |
55 | else if (Posix.FileSys.ST.isDir stat) then Kind.dir | |
56 | else if (Posix.FileSys.ST.isChr stat) then Kind.tty | |
57 | else if (Posix.FileSys.ST.isBlk stat) then Kind.device (* ?? *) | |
58 | else if (Posix.FileSys.ST.isLink stat) then Kind.symlink | |
59 | else if (Posix.FileSys.ST.isFIFO stat) then Kind.pipe | |
60 | else if (Posix.FileSys.ST.isSock stat) then Kind.socket | |
61 | else K "UNKNOWN" | |
62 | end | |
63 | ||
64 | type poll_flags = {rd: bool, wr: bool, pri: bool} | |
65 | datatype poll_desc = PollDesc of iodesc * poll_flags | |
66 | datatype poll_info = PollInfo of iodesc * poll_flags | |
67 | ||
68 | (* create a polling operation on the given descriptor; note that | |
69 | * not all I/O devices support polling, but for the time being, we | |
70 | * don't test for this. | |
71 | *) | |
72 | fun pollDesc iod = SOME (PollDesc (iod, {rd=false, wr=false, pri=false})) | |
73 | ||
74 | (* return the I/O descriptor that is being polled *) | |
75 | fun pollToIODesc (PollDesc (iod, _)) = iod | |
76 | ||
77 | exception Poll | |
78 | ||
79 | (* set polling events; if the polling operation is not appropriate | |
80 | * for the underlying I/O device, then the Poll exception is raised. | |
81 | *) | |
82 | fun pollIn (PollDesc (iod, {wr, pri, ...}: poll_flags)) = | |
83 | PollDesc (iod, {rd=true, wr=wr, pri=pri}) | |
84 | fun pollOut (PollDesc (iod, {rd, pri, ...}: poll_flags)) = | |
85 | PollDesc (iod, {rd=rd, wr=true, pri=pri}) | |
86 | fun pollPri (PollDesc (iod, {rd, wr, ...}: poll_flags)) = | |
87 | PollDesc (iod, {rd=rd, wr=wr, pri=true}) | |
88 | ||
89 | (* polling function *) | |
90 | local | |
91 | structure Prim = PrimitiveFFI.OS.IO | |
92 | fun join (false, _, w) = w | |
93 | | join (true, b, w) = C_Short.orb(w, b) | |
94 | fun test (w, b) = (C_Short.andb(w, b) <> 0) | |
95 | val rdBit = PrimitiveFFI.OS.IO.POLLIN | |
96 | and wrBit = PrimitiveFFI.OS.IO.POLLOUT | |
97 | and priBit = PrimitiveFFI.OS.IO.POLLPRI | |
98 | fun fromPollDesc (PollDesc (iod, {rd, wr, pri})) = | |
99 | ( iodToFd iod, | |
100 | join (rd, rdBit, | |
101 | join (wr, wrBit, | |
102 | join (pri, priBit, 0))) | |
103 | ) | |
104 | fun toPollInfo (fd, i) = | |
105 | PollInfo (fdToIod fd, { | |
106 | rd = test(i, rdBit), | |
107 | wr = test(i, wrBit), | |
108 | pri = test(i, priBit) | |
109 | }) | |
110 | in | |
111 | fun poll (pds, timeOut) = let | |
112 | val (fds, events) = ListPair.unzip (List.map fromPollDesc pds) | |
113 | val fds = Vector.fromList fds | |
114 | val n = Vector.length fds | |
115 | val events = Vector.fromList events | |
116 | val timeOut = | |
117 | case timeOut of | |
118 | NONE => ~1 | |
119 | | SOME t => | |
120 | if Time.< (t, Time.zeroTime) | |
121 | then Error.raiseSys Error.inval | |
122 | else (C_Int.fromLarge (Time.toMilliseconds t) | |
123 | handle Overflow => Error.raiseSys Error.inval) | |
124 | val revents = Array.array (n, 0: C_Short.t) | |
125 | val _ = Posix.Error.SysCall.simpleRestart | |
126 | (fn () => Prim.poll (PrePosix.FileDesc.vectorToRep fds, | |
127 | events, | |
128 | C_NFds.fromInt n, | |
129 | timeOut, | |
130 | revents)) | |
131 | in | |
132 | Array.foldri | |
133 | (fn (i, w, l) => | |
134 | if w <> 0 | |
135 | then (toPollInfo (Vector.sub (fds, i), w))::l | |
136 | else l) | |
137 | [] | |
138 | revents | |
139 | end | |
140 | end (* local *) | |
141 | ||
142 | (* check for conditions *) | |
143 | fun isIn (PollInfo(_, flgs)) = #rd flgs | |
144 | fun isOut (PollInfo(_, flgs)) = #wr flgs | |
145 | fun isPri (PollInfo(_, flgs)) = #pri flgs | |
146 | fun infoToPollDesc (PollInfo arg) = PollDesc arg | |
147 | end (* OS_IO *) | |
148 | ||
149 | ||
150 | (* | |
151 | * $Log: os-io.sml, v $ | |
152 | * Revision 1.4 1997/07/31 17:25:26 jhr | |
153 | * We are now using 32-bit ints to represent the seconds portion of a | |
154 | * time value. This was required to handle the change in the type of | |
155 | * Time.{to, from}{Seconds, Milliseconds, Microseconds}. | |
156 | * | |
157 | * Revision 1.3 1997/06/07 15:27:51 jhr | |
158 | * SML'97 Basis Library changes (phase 3; Posix changes) | |
159 | * | |
160 | * Revision 1.2 1997/06/02 19:16:19 jhr | |
161 | * SML'97 Basis Library changes (phase 2) | |
162 | * | |
163 | * Revision 1.1.1.1 1997/01/14 01:38:25 george | |
164 | * Version 109.24 | |
165 | * | |
166 | *) |