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/Posix/posix-tty.sml
ViewVC logotype

Annotation of /sml/trunk/src/compiler/PervEnv/Posix/posix-tty.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 17 - (view) (download)
Original Path: sml/branches/SMLNJ/src/compiler/PervEnv/Posix/posix-tty.sml

1 : monnier 16 (* posix-tty.sml
2 :     *
3 :     * COPYRIGHT (c) 1995 AT&T Bell Laboratories.
4 :     *
5 :     * Structure for POSIX 1003.1 operations on terminal devices
6 :     *
7 :     *)
8 :    
9 :     structure POSIX_TTY =
10 :     struct
11 :    
12 :     structure FS = POSIX_FileSys
13 :     structure P = POSIX_Process
14 :    
15 :     type pid = POSIX_Process.pid
16 :     type file_desc = POSIX_FileSys.file_desc
17 :    
18 :     type word = SysWord.word
19 :     type s_int = SysInt.int
20 :    
21 :     val ++ = SysWord.orb
22 :     val & = SysWord.andb
23 :     infix ++ &
24 :    
25 :     fun cfun x = CInterface.c_function "POSIX-TTY" x
26 :     val osval : string -> s_int = cfun "osval"
27 :     val w_osval = SysWord.fromInt o osval
28 :    
29 :     structure I =
30 :     struct
31 :     datatype flags = F of word
32 :    
33 :     fun fromWord w = F w
34 :     fun toWord (F w) = w
35 :    
36 :     fun flags ms = F(List.foldl (fn (F m,acc) => m ++ acc) 0w0 ms)
37 :     fun anySet (F m, F m') = (m & m') <> 0w0
38 :     fun allSet (F m, F m') = (m & m') = m
39 :    
40 :     val brkint = F (w_osval "BRKINT")
41 :     val icrnl = F (w_osval "ICRNL")
42 :     val ignbrk = F (w_osval "IGNBRK")
43 :     val igncr = F (w_osval "IGNCR")
44 :     val ignpar = F (w_osval "IGNPAR")
45 :     val inlcr = F (w_osval "INLCR")
46 :     val inpck = F (w_osval "INPCK")
47 :     val istrip = F (w_osval "ISTRIP")
48 :     val ixoff = F (w_osval "IXOFF")
49 :     val ixon = F (w_osval "IXON")
50 :     val parmrk = F (w_osval "PARMRK")
51 :     end
52 :    
53 :     structure O =
54 :     struct
55 :     datatype flags = F of word
56 :    
57 :     fun fromWord w = F w
58 :     fun toWord (F w) = w
59 :    
60 :     fun flags ms = F(List.foldl (fn (F m,acc) => m ++ acc) 0w0 ms)
61 :     fun anySet (F m, F m') = (m & m') <> 0w0
62 :     fun allSet (F m, F m') = (m & m') = m
63 :    
64 :     val opost = F (w_osval "OPOST")
65 :     end
66 :    
67 :     structure C =
68 :     struct
69 :     datatype flags = F of word
70 :    
71 :     fun fromWord w = F w
72 :     fun toWord (F w) = w
73 :    
74 :     fun flags ms = F(List.foldl (fn (F m,acc) => m ++ acc) 0w0 ms)
75 :     fun anySet (F m, F m') = (m & m') <> 0w0
76 :     fun allSet (F m, F m') = (m & m') = m
77 :    
78 :     val clocal = F (w_osval "CLOCAL")
79 :     val cread = F (w_osval "CREAD")
80 :     val csize = F (w_osval "CSIZE")
81 :     val cs5 = F (w_osval "CS5")
82 :     val cs6 = F (w_osval "CS6")
83 :     val cs7 = F (w_osval "CS7")
84 :     val cs8 = F (w_osval "CS8")
85 :     val cstopb = F (w_osval "CSTOPB")
86 :     val hupcl = F (w_osval "HUPCL")
87 :     val parenb = F (w_osval "PARENB")
88 :     val parodd = F (w_osval "PARODD")
89 :     end
90 :    
91 :     structure L =
92 :     struct
93 :     datatype flags = F of word
94 :    
95 :     fun fromWord w = F w
96 :     fun toWord (F w) = w
97 :    
98 :     fun flags ms = F(List.foldl (fn (F m,acc) => m ++ acc) 0w0 ms)
99 :     fun anySet (F m, F m') = (m & m') <> 0w0
100 :     fun allSet (F m, F m') = (m & m') = m
101 :    
102 :     val echo = F (w_osval "ECHO")
103 :     val echoe = F (w_osval "ECHOE")
104 :     val echok = F (w_osval "ECHOK")
105 :     val echonl = F (w_osval "ECHONL")
106 :     val icanon = F (w_osval "ICANON")
107 :     val iexten = F (w_osval "IEXTEN")
108 :     val isig = F (w_osval "ISIG")
109 :     val noflsh = F (w_osval "NOFLSH")
110 :     val tostop = F (w_osval "TOSTOP")
111 :     end
112 :    
113 :     structure V =
114 :     struct
115 :     structure WV = Word8Vector
116 :     structure WA = Word8Array
117 :     structure B = Byte
118 :    
119 :     val nccs = osval "NCCS"
120 :    
121 :     val eof = (osval "EOF")
122 :     val eol = (osval "EOL")
123 :     val erase = (osval "ERASE")
124 :     val intr = (osval "INTR")
125 :     val kill = (osval "KILL")
126 :     val min = (osval "MIN")
127 :     val quit = (osval "QUIT")
128 :     val susp = (osval "SUSP")
129 :     val time = (osval "TIME")
130 :     val start = (osval "START")
131 :     val stop = (osval "STOP")
132 :    
133 :     datatype cc = CC of WV.vector
134 :    
135 :     fun mkCC (arr, l) = let
136 :     fun update (i, c) = WA.update(arr, i, B.charToByte c)
137 :     in
138 :     List.app update l;
139 :     CC (WA.extract (arr, 0, NONE))
140 :     end
141 :    
142 :     fun cc vals = mkCC (WA.array(nccs, 0w0), vals)
143 :     fun update (CC v, vals) =
144 :     mkCC (WA.tabulate (nccs, fn i => WV.sub(v,i)), vals)
145 :     fun sub (CC v, i) = B.byteToChar (WV.sub(v,i))
146 :     end
147 :    
148 :     datatype speed = B of word
149 :     fun compareSpeed (B w, B w') =
150 :     if SysWord.<(w, w') then LESS
151 :     else if w = w' then EQUAL
152 :     else GREATER
153 :     fun speedToWord (B w) = w
154 :     fun wordToSpeed w = B w
155 :     val b0 = B (w_osval "B0")
156 :     val b50 = B (w_osval "B50")
157 :     val b75 = B (w_osval "B75")
158 :     val b110 = B (w_osval "B110")
159 :     val b134 = B (w_osval "B134")
160 :     val b150 = B (w_osval "B150")
161 :     val b200 = B (w_osval "B200")
162 :     val b300 = B (w_osval "B300")
163 :     val b600 = B (w_osval "B600")
164 :     val b1200 = B (w_osval "B1200")
165 :     val b1800 = B (w_osval "B1800")
166 :     val b2400 = B (w_osval "B2400")
167 :     val b4800 = B (w_osval "B4800")
168 :     val b9600 = B (w_osval "B9600")
169 :     val b19200 = B (w_osval "B19200")
170 :     val b38400 = B (w_osval "B38400")
171 :    
172 :     datatype termios = TIOS of {
173 :     iflag : I.flags,
174 :     oflag : O.flags,
175 :     cflag : C.flags,
176 :     lflag : L.flags,
177 :     cc : V.cc,
178 :     ispeed : speed,
179 :     ospeed : speed
180 :     }
181 :    
182 :     fun termios arg = TIOS arg
183 :     fun fieldsOf (TIOS arg) = arg
184 :     fun getiflag (TIOS{iflag, ...}) = iflag
185 :     fun getoflag (TIOS{oflag, ...}) = oflag
186 :     fun getcflag (TIOS{cflag, ...}) = cflag
187 :     fun getlflag (TIOS{lflag, ...}) = lflag
188 :     fun getcc (TIOS{cc,...}) = cc
189 :    
190 :     fun getospeed (TIOS{ospeed,...}) = ospeed
191 :     fun getispeed (TIOS{ispeed,...}) = ispeed
192 :    
193 :     fun setospeed (TIOS r, ospeed) =
194 :     TIOS {
195 :     iflag = #iflag r,
196 :     oflag = #oflag r,
197 :     cflag = #cflag r,
198 :     lflag = #lflag r,
199 :     cc = #cc r,
200 :     ispeed = #ispeed r,
201 :     ospeed = ospeed
202 :     }
203 :     fun setispeed (TIOS r, ispeed) =
204 :     TIOS {
205 :     iflag = #iflag r,
206 :     oflag = #oflag r,
207 :     cflag = #cflag r,
208 :     lflag = #lflag r,
209 :     cc = #cc r,
210 :     ispeed = ispeed,
211 :     ospeed = #ospeed r
212 :     }
213 :    
214 :     structure TC =
215 :     struct
216 :     datatype set_action = SA of s_int
217 :    
218 :     val sanow = SA (osval "TCSANOW")
219 :     val sadrain = SA (osval "TCSADRAIN")
220 :     val saflush = SA (osval "TCSAFLUSH")
221 :    
222 :     datatype flow_action = FA of s_int
223 :    
224 :     val ooff = FA (osval "TCOOFF")
225 :     val oon = FA (osval "TCOON")
226 :     val ioff = FA (osval "TCIOFF")
227 :     val ion = FA (osval "TCION")
228 :    
229 :     datatype queue_sel = QS of s_int
230 :    
231 :     val iflush = QS (osval "TCIFLUSH")
232 :     val oflush = QS (osval "TCOFLUSH")
233 :     val ioflush = QS (osval "TCIOFLUSH")
234 :     end
235 :    
236 :     type termio_rep = (
237 :     word * (* iflags *)
238 :     word * (* oflags *)
239 :     word * (* cflags *)
240 :     word * (* lflags *)
241 :     V.WV.vector * (* cc *)
242 :     word * (* inspeed *)
243 :     word (* outspeed *)
244 :     )
245 :    
246 :     val tcgetattr : int -> termio_rep = cfun "tcgetattr"
247 :     fun getattr fd = let
248 :     val (ifs,ofs,cfs,lfs,cc,isp,osp) = tcgetattr (FS.intOf fd)
249 :     in
250 :     TIOS {
251 :     iflag = I.F ifs,
252 :     oflag = O.F ofs,
253 :     cflag = C.F cfs,
254 :     lflag = L.F lfs,
255 :     cc = V.CC cc,
256 :     ispeed = B isp,
257 :     ospeed = B osp
258 :     }
259 :     end
260 :    
261 :     val tcsetattr : int * s_int * termio_rep -> unit = cfun "tcsetattr"
262 :     fun setattr (fd, TC.SA sa, TIOS tios) = let
263 :     val (I.F iflag) = #iflag tios
264 :     val (O.F oflag) = #oflag tios
265 :     val (C.F cflag) = #cflag tios
266 :     val (L.F lflag) = #lflag tios
267 :     val (V.CC cc) = #cc tios
268 :     val (B ispeed) = #ispeed tios
269 :     val (B ospeed) = #ospeed tios
270 :     val trep = (iflag,oflag,cflag,lflag,cc,ispeed,ospeed)
271 :     in
272 :     tcsetattr (FS.intOf fd, sa, trep)
273 :     end
274 :    
275 :     val tcsendbreak : int * int -> unit = cfun "tcsendbreak"
276 :     fun sendbreak (fd, duration) = tcsendbreak (FS.intOf fd, duration)
277 :    
278 :     val tcdrain : int -> unit = cfun "tcdrain"
279 :     fun drain fd = tcdrain (FS.intOf fd)
280 :    
281 :     val tcflush : int * s_int -> unit = cfun "tcflush"
282 :     fun flush (fd, TC.QS qs) = tcflush (FS.intOf fd, qs)
283 :    
284 :     val tcflow : int * s_int -> unit = cfun "tcflow"
285 :     fun flow (fd, TC.FA action) = tcflow (FS.intOf fd, action)
286 :    
287 :     val tcgetpgrp : int -> s_int = cfun "tcgetpgrp"
288 :     fun getpgrp fd = P.PID(tcgetpgrp(FS.intOf fd))
289 :    
290 :     val tcsetpgrp : int * s_int -> unit = cfun "tcsetpgrp"
291 :     fun setpgrp (fd, P.PID pid) = tcsetpgrp(FS.intOf fd, pid)
292 :    
293 :     end (* structure POSIX_TTY *)
294 :    
295 :     (*
296 :     * $Log: posix-tty.sml,v $
297 :     * Revision 1.3 1997/12/16 16:17:53 jhr
298 :     * Name change: wordTo ==> fromWord in POSIX_FLAGS signature.
299 :     *
300 :     * Revision 1.2 1997/06/07 15:27:43 jhr
301 :     * SML'97 Basis Library changes (phase 3; Posix changes)
302 :     *
303 :     * Revision 1.1.1.1 1997/01/14 01:38:23 george
304 :     * Version 109.24
305 :     *
306 :     *)

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