1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
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 --
9 -- Copyright (C) 2007-2024, AdaCore --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 -- This is the Windows implementation of this package
34 with Ada
.Streams
; use Ada
.Streams
, Ada
;
36 with System
; use System
;
37 with System
.Communication
; use System
.Communication
;
38 with System
.CRTL
; use System
.CRTL
;
39 with System
.Win32
; use System
.Win32
;
40 with System
.Win32
.Ext
; use System
.Win32
.Ext
;
44 package body GNAT
.Serial_Communications
is
46 package OSC
renames System
.OS_Constants
;
50 C_Bits
: constant array (Data_Bits
) of Interfaces
.C
.unsigned
:= (8, 7);
51 C_Parity
: constant array (Parity_Check
) of Interfaces
.C
.unsigned
:=
52 (None
=> NOPARITY
, Odd
=> ODDPARITY
, Even
=> EVENPARITY
);
53 C_Stop_Bits
: constant array (Stop_Bits_Number
) of Interfaces
.C
.unsigned
:=
54 (One
=> ONESTOPBIT
, Two
=> TWOSTOPBITS
);
60 procedure Raise_Error
(Message
: String; Error
: DWORD
:= GetLastError
);
61 pragma No_Return
(Raise_Error
);
67 procedure Close
(Port
: in out Serial_Port
) is
72 Success
:= CloseHandle
(HANDLE
(Port
.H
));
75 if Success
= Win32
.FALSE then
76 Raise_Error
("error closing the port");
85 function Name
(Number
: Positive) return Port_Name
is
86 N_Img
: constant String := Positive'Image (Number
);
90 Port_Name
("\\.\COM" & N_Img
(N_Img
'First + 1 .. N_Img
'Last));
93 Port_Name
("COM" & N_Img
(N_Img
'First + 1 .. N_Img
'Last) & ':');
102 (Port
: out Serial_Port
;
105 C_Name
: constant String := String (Name
) & ASCII
.NUL
;
107 pragma Unreferenced
(Success
);
111 Success
:= CloseHandle
(HANDLE
(Port
.H
));
114 Port
.H
:= CreateFileA
115 (lpFileName
=> C_Name
(C_Name
'First)'Address,
116 dwDesiredAccess
=> GENERIC_READ
or GENERIC_WRITE
,
118 lpSecurityAttributes
=> null,
119 dwCreationDisposition
=> OPEN_EXISTING
,
120 dwFlagsAndAttributes
=> 0,
123 pragma Assert
(INVALID_HANDLE_VALUE
= -1);
125 if Port
.H
= Serial_Port_Descriptor
(INVALID_HANDLE_VALUE
) then
126 Raise_Error
("cannot open com port");
134 procedure Raise_Error
(Message
: String; Error
: DWORD
:= GetLastError
) is
136 raise Serial_Error
with Message
138 then " (" & GNAT
.OS_Lib
.Errno_Message
(Err
=> Integer (Error
)) & ')'
146 overriding
procedure Read
147 (Port
: in out Serial_Port
;
148 Buffer
: out Stream_Element_Array
;
149 Last
: out Stream_Element_Offset
)
152 Read_Last
: aliased DWORD
;
156 Raise_Error
("read: port not opened", 0);
161 (hFile
=> HANDLE
(Port
.H
),
162 lpBuffer
=> Buffer
(Buffer
'First)'Address,
163 nNumberOfBytesToRead
=> DWORD
(Buffer
'Length),
164 lpNumberOfBytesRead
=> Read_Last
'Access,
165 lpOverlapped
=> null);
167 if Success
= Win32
.FALSE then
168 Raise_Error
("read error");
171 Last
:= Last_Index
(Buffer
'First, CRTL
.size_t
(Read_Last
));
180 Rate
: Data_Rate
:= B9600
;
181 Bits
: Data_Bits
:= CS8
;
182 Stop_Bits
: Stop_Bits_Number
:= One
;
183 Parity
: Parity_Check
:= None
;
184 Block
: Boolean := True;
185 Local
: Boolean := True;
186 Flow
: Flow_Control
:= None
;
187 Timeout
: Duration := 10.0)
189 pragma Unreferenced
(Local
);
192 Com_Time_Out
: aliased COMMTIMEOUTS
;
193 Com_Settings
: aliased DCB
;
197 Raise_Error
("set: port not opened", 0);
200 Success
:= GetCommState
(HANDLE
(Port
.H
), Com_Settings
'Access);
202 if Success
= Win32
.FALSE then
203 Success
:= CloseHandle
(HANDLE
(Port
.H
));
204 Raise_Error
("set: cannot get comm state");
207 Com_Settings
.BaudRate
:= DWORD
(Data_Rate_Value
(Rate
));
208 Com_Settings
.fParity
:= 1;
209 Com_Settings
.fBinary
:= Bits1
(System
.Win32
.TRUE);
210 Com_Settings
.fOutxDsrFlow
:= 0;
211 Com_Settings
.fDsrSensitivity
:= 0;
212 Com_Settings
.fDtrControl
:= OSC
.DTR_CONTROL_ENABLE
;
213 Com_Settings
.fInX
:= 0;
214 Com_Settings
.fRtsControl
:= OSC
.RTS_CONTROL_ENABLE
;
218 Com_Settings
.fOutX
:= 0;
219 Com_Settings
.fOutxCtsFlow
:= 0;
222 Com_Settings
.fOutX
:= 0;
223 Com_Settings
.fOutxCtsFlow
:= 1;
226 Com_Settings
.fOutX
:= 1;
227 Com_Settings
.fOutxCtsFlow
:= 0;
230 Com_Settings
.fAbortOnError
:= 0;
231 Com_Settings
.ByteSize
:= BYTE
(C_Bits
(Bits
));
232 Com_Settings
.Parity
:= BYTE
(C_Parity
(Parity
));
233 Com_Settings
.StopBits
:= BYTE
(C_Stop_Bits
(Stop_Bits
));
235 Success
:= SetCommState
(HANDLE
(Port
.H
), Com_Settings
'Access);
237 if Success
= Win32
.FALSE then
238 Success
:= CloseHandle
(HANDLE
(Port
.H
));
239 Raise_Error
("cannot set comm state");
242 -- Set the timeout status, to honor our spec with respect to read
243 -- timeouts. Always disconnect write timeouts.
245 -- Blocking reads - no timeout at all
248 Com_Time_Out
:= (others => 0);
250 -- Non-blocking reads and null timeout - immediate return with what we
251 -- have - set ReadIntervalTimeout to MAXDWORD.
253 elsif Timeout
= 0.0 then
255 (ReadIntervalTimeout
=> DWORD
'Last,
258 -- Non-blocking reads with timeout - set total read timeout accordingly
262 (ReadTotalTimeoutConstant
=> DWORD
(1000 * Timeout
),
268 (hFile
=> HANDLE
(Port
.H
),
269 lpCommTimeouts
=> Com_Time_Out
'Access);
271 if Success
= Win32
.FALSE then
272 Raise_Error
("cannot set the timeout");
280 procedure To_Ada
(Port
: out Serial_Port
; Fd
: Serial_Port_Descriptor
) is
289 overriding
procedure Write
290 (Port
: in out Serial_Port
;
291 Buffer
: Stream_Element_Array
)
294 Temp_Last
: aliased DWORD
;
298 Raise_Error
("write: port not opened", 0);
303 (hFile
=> HANDLE
(Port
.H
),
304 lpBuffer
=> Buffer
'Address,
305 nNumberOfBytesToWrite
=> DWORD
(Buffer
'Length),
306 lpNumberOfBytesWritten
=> Temp_Last
'Access,
307 lpOverlapped
=> null);
309 if Success
= Win32
.FALSE
310 or else Stream_Element_Offset
(Temp_Last
) /= Buffer
'Length
312 Raise_Error
("failed to write data");
316 end GNAT
.Serial_Communications
;