Mercurial > hg > CbC > CbC_gcc
comparison gcc/ada/libgnat/g-sercom__mingw.adb @ 111:04ced10e8804
gcc 7
author | kono |
---|---|
date | Fri, 27 Oct 2017 22:46:09 +0900 |
parents | |
children | 84e7813d76e9 |
comparison
equal
deleted
inserted
replaced
68:561a7518be6b | 111:04ced10e8804 |
---|---|
1 ------------------------------------------------------------------------------ | |
2 -- -- | |
3 -- GNAT COMPILER COMPONENTS -- | |
4 -- -- | |
5 -- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- | |
6 -- -- | |
7 -- B o d y -- | |
8 -- -- | |
9 -- Copyright (C) 2007-2017, AdaCore -- | |
10 -- -- | |
11 -- GNAT is free software; you can redistribute it and/or modify it under -- | |
12 -- terms of the GNU General Public License as published by the Free Soft- -- | |
13 -- ware Foundation; either version 3, or (at your option) any later ver- -- | |
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
16 -- or FITNESS FOR A PARTICULAR PURPOSE. -- | |
17 -- -- | |
18 -- As a special exception under Section 7 of GPL version 3, you are granted -- | |
19 -- additional permissions described in the GCC Runtime Library Exception, -- | |
20 -- version 3.1, as published by the Free Software Foundation. -- | |
21 -- -- | |
22 -- You should have received a copy of the GNU General Public License and -- | |
23 -- a copy of the GCC Runtime Library Exception along with this program; -- | |
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- | |
25 -- <http://www.gnu.org/licenses/>. -- | |
26 -- -- | |
27 -- GNAT was originally developed by the GNAT team at New York University. -- | |
28 -- Extensive contributions were provided by Ada Core Technologies Inc. -- | |
29 -- -- | |
30 ------------------------------------------------------------------------------ | |
31 | |
32 -- This is the Windows implementation of this package | |
33 | |
34 with Ada.Streams; use Ada.Streams; | |
35 with Ada.Unchecked_Deallocation; use Ada; | |
36 | |
37 with System; use System; | |
38 with System.Communication; use System.Communication; | |
39 with System.CRTL; use System.CRTL; | |
40 with System.OS_Constants; | |
41 with System.Win32; use System.Win32; | |
42 with System.Win32.Ext; use System.Win32.Ext; | |
43 | |
44 with GNAT.OS_Lib; | |
45 | |
46 package body GNAT.Serial_Communications is | |
47 | |
48 package OSC renames System.OS_Constants; | |
49 | |
50 -- Common types | |
51 | |
52 type Port_Data is new HANDLE; | |
53 | |
54 C_Bits : constant array (Data_Bits) of Interfaces.C.unsigned := (8, 7); | |
55 C_Parity : constant array (Parity_Check) of Interfaces.C.unsigned := | |
56 (None => NOPARITY, Odd => ODDPARITY, Even => EVENPARITY); | |
57 C_Stop_Bits : constant array (Stop_Bits_Number) of Interfaces.C.unsigned := | |
58 (One => ONESTOPBIT, Two => TWOSTOPBITS); | |
59 | |
60 ----------- | |
61 -- Files -- | |
62 ----------- | |
63 | |
64 procedure Raise_Error (Message : String; Error : DWORD := GetLastError); | |
65 pragma No_Return (Raise_Error); | |
66 | |
67 ----------- | |
68 -- Close -- | |
69 ----------- | |
70 | |
71 procedure Close (Port : in out Serial_Port) is | |
72 procedure Unchecked_Free is | |
73 new Unchecked_Deallocation (Port_Data, Port_Data_Access); | |
74 | |
75 Success : BOOL; | |
76 | |
77 begin | |
78 if Port.H /= null then | |
79 Success := CloseHandle (HANDLE (Port.H.all)); | |
80 Unchecked_Free (Port.H); | |
81 | |
82 if Success = Win32.FALSE then | |
83 Raise_Error ("error closing the port"); | |
84 end if; | |
85 end if; | |
86 end Close; | |
87 | |
88 ---------- | |
89 -- Name -- | |
90 ---------- | |
91 | |
92 function Name (Number : Positive) return Port_Name is | |
93 N_Img : constant String := Positive'Image (Number); | |
94 begin | |
95 if Number > 9 then | |
96 return | |
97 Port_Name ("\\.\COM" & N_Img (N_Img'First + 1 .. N_Img'Last)); | |
98 else | |
99 return | |
100 Port_Name ("COM" & N_Img (N_Img'First + 1 .. N_Img'Last) & ':'); | |
101 end if; | |
102 end Name; | |
103 | |
104 ---------- | |
105 -- Open -- | |
106 ---------- | |
107 | |
108 procedure Open | |
109 (Port : out Serial_Port; | |
110 Name : Port_Name) | |
111 is | |
112 C_Name : constant String := String (Name) & ASCII.NUL; | |
113 Success : BOOL; | |
114 pragma Unreferenced (Success); | |
115 | |
116 begin | |
117 if Port.H = null then | |
118 Port.H := new Port_Data; | |
119 else | |
120 Success := CloseHandle (HANDLE (Port.H.all)); | |
121 end if; | |
122 | |
123 Port.H.all := CreateFileA | |
124 (lpFileName => C_Name (C_Name'First)'Address, | |
125 dwDesiredAccess => GENERIC_READ or GENERIC_WRITE, | |
126 dwShareMode => 0, | |
127 lpSecurityAttributes => null, | |
128 dwCreationDisposition => OPEN_EXISTING, | |
129 dwFlagsAndAttributes => 0, | |
130 hTemplateFile => 0); | |
131 | |
132 if Port.H.all = Port_Data (INVALID_HANDLE_VALUE) then | |
133 Raise_Error ("cannot open com port"); | |
134 end if; | |
135 end Open; | |
136 | |
137 ----------------- | |
138 -- Raise_Error -- | |
139 ----------------- | |
140 | |
141 procedure Raise_Error (Message : String; Error : DWORD := GetLastError) is | |
142 begin | |
143 raise Serial_Error with Message | |
144 & (if Error /= 0 | |
145 then " (" & GNAT.OS_Lib.Errno_Message (Err => Integer (Error)) & ')' | |
146 else ""); | |
147 end Raise_Error; | |
148 | |
149 ---------- | |
150 -- Read -- | |
151 ---------- | |
152 | |
153 overriding procedure Read | |
154 (Port : in out Serial_Port; | |
155 Buffer : out Stream_Element_Array; | |
156 Last : out Stream_Element_Offset) | |
157 is | |
158 Success : BOOL; | |
159 Read_Last : aliased DWORD; | |
160 | |
161 begin | |
162 if Port.H = null then | |
163 Raise_Error ("read: port not opened", 0); | |
164 end if; | |
165 | |
166 Success := | |
167 ReadFile | |
168 (hFile => HANDLE (Port.H.all), | |
169 lpBuffer => Buffer (Buffer'First)'Address, | |
170 nNumberOfBytesToRead => DWORD (Buffer'Length), | |
171 lpNumberOfBytesRead => Read_Last'Access, | |
172 lpOverlapped => null); | |
173 | |
174 if Success = Win32.FALSE then | |
175 Raise_Error ("read error"); | |
176 end if; | |
177 | |
178 Last := Last_Index (Buffer'First, size_t (Read_Last)); | |
179 end Read; | |
180 | |
181 --------- | |
182 -- Set -- | |
183 --------- | |
184 | |
185 procedure Set | |
186 (Port : Serial_Port; | |
187 Rate : Data_Rate := B9600; | |
188 Bits : Data_Bits := CS8; | |
189 Stop_Bits : Stop_Bits_Number := One; | |
190 Parity : Parity_Check := None; | |
191 Block : Boolean := True; | |
192 Local : Boolean := True; | |
193 Flow : Flow_Control := None; | |
194 Timeout : Duration := 10.0) | |
195 is | |
196 pragma Unreferenced (Local); | |
197 | |
198 Success : BOOL; | |
199 Com_Time_Out : aliased COMMTIMEOUTS; | |
200 Com_Settings : aliased DCB; | |
201 | |
202 begin | |
203 if Port.H = null then | |
204 Raise_Error ("set: port not opened", 0); | |
205 end if; | |
206 | |
207 Success := GetCommState (HANDLE (Port.H.all), Com_Settings'Access); | |
208 | |
209 if Success = Win32.FALSE then | |
210 Success := CloseHandle (HANDLE (Port.H.all)); | |
211 Port.H.all := 0; | |
212 Raise_Error ("set: cannot get comm state"); | |
213 end if; | |
214 | |
215 Com_Settings.BaudRate := DWORD (Data_Rate_Value (Rate)); | |
216 Com_Settings.fParity := 1; | |
217 Com_Settings.fBinary := Bits1 (System.Win32.TRUE); | |
218 Com_Settings.fOutxDsrFlow := 0; | |
219 Com_Settings.fDsrSensitivity := 0; | |
220 Com_Settings.fDtrControl := OSC.DTR_CONTROL_ENABLE; | |
221 Com_Settings.fInX := 0; | |
222 Com_Settings.fRtsControl := OSC.RTS_CONTROL_ENABLE; | |
223 | |
224 case Flow is | |
225 when None => | |
226 Com_Settings.fOutX := 0; | |
227 Com_Settings.fOutxCtsFlow := 0; | |
228 | |
229 when RTS_CTS => | |
230 Com_Settings.fOutX := 0; | |
231 Com_Settings.fOutxCtsFlow := 1; | |
232 | |
233 when Xon_Xoff => | |
234 Com_Settings.fOutX := 1; | |
235 Com_Settings.fOutxCtsFlow := 0; | |
236 end case; | |
237 | |
238 Com_Settings.fAbortOnError := 0; | |
239 Com_Settings.ByteSize := BYTE (C_Bits (Bits)); | |
240 Com_Settings.Parity := BYTE (C_Parity (Parity)); | |
241 Com_Settings.StopBits := BYTE (C_Stop_Bits (Stop_Bits)); | |
242 | |
243 Success := SetCommState (HANDLE (Port.H.all), Com_Settings'Access); | |
244 | |
245 if Success = Win32.FALSE then | |
246 Success := CloseHandle (HANDLE (Port.H.all)); | |
247 Port.H.all := 0; | |
248 Raise_Error ("cannot set comm state"); | |
249 end if; | |
250 | |
251 -- Set the timeout status, to honor our spec with respect to read | |
252 -- timeouts. Always disconnect write timeouts. | |
253 | |
254 -- Blocking reads - no timeout at all | |
255 | |
256 if Block then | |
257 Com_Time_Out := (others => 0); | |
258 | |
259 -- Non-blocking reads and null timeout - immediate return with what we | |
260 -- have - set ReadIntervalTimeout to MAXDWORD. | |
261 | |
262 elsif Timeout = 0.0 then | |
263 Com_Time_Out := | |
264 (ReadIntervalTimeout => DWORD'Last, | |
265 others => 0); | |
266 | |
267 -- Non-blocking reads with timeout - set total read timeout accordingly | |
268 | |
269 else | |
270 Com_Time_Out := | |
271 (ReadTotalTimeoutConstant => DWORD (1000 * Timeout), | |
272 others => 0); | |
273 end if; | |
274 | |
275 Success := | |
276 SetCommTimeouts | |
277 (hFile => HANDLE (Port.H.all), | |
278 lpCommTimeouts => Com_Time_Out'Access); | |
279 | |
280 if Success = Win32.FALSE then | |
281 Raise_Error ("cannot set the timeout"); | |
282 end if; | |
283 end Set; | |
284 | |
285 ----------- | |
286 -- Write -- | |
287 ----------- | |
288 | |
289 overriding procedure Write | |
290 (Port : in out Serial_Port; | |
291 Buffer : Stream_Element_Array) | |
292 is | |
293 Success : BOOL; | |
294 Temp_Last : aliased DWORD; | |
295 | |
296 begin | |
297 if Port.H = null then | |
298 Raise_Error ("write: port not opened", 0); | |
299 end if; | |
300 | |
301 Success := | |
302 WriteFile | |
303 (hFile => HANDLE (Port.H.all), | |
304 lpBuffer => Buffer'Address, | |
305 nNumberOfBytesToWrite => DWORD (Buffer'Length), | |
306 lpNumberOfBytesWritten => Temp_Last'Access, | |
307 lpOverlapped => null); | |
308 | |
309 if Success = Win32.FALSE | |
310 or else Stream_Element_Offset (Temp_Last) /= Buffer'Length | |
311 then | |
312 Raise_Error ("failed to write data"); | |
313 end if; | |
314 end Write; | |
315 | |
316 end GNAT.Serial_Communications; |