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-2012, 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
.Unchecked_Deallocation
; use Ada
;
35 with Ada
.Streams
; use Ada
.Streams
;
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
;
44 package body GNAT
.Serial_Communications
is
46 package OSC
renames System
.OS_Constants
;
50 type Port_Data
is new HANDLE
;
52 C_Bits
: constant array (Data_Bits
) of Interfaces
.C
.unsigned
:= (8, 7);
53 C_Parity
: constant array (Parity_Check
) of Interfaces
.C
.unsigned
:=
54 (None
=> NOPARITY
, Odd
=> ODDPARITY
, Even
=> EVENPARITY
);
55 C_Stop_Bits
: constant array (Stop_Bits_Number
) of Interfaces
.C
.unsigned
:=
56 (One
=> ONESTOPBIT
, Two
=> TWOSTOPBITS
);
62 procedure Raise_Error
(Message
: String; Error
: DWORD
:= GetLastError
);
63 pragma No_Return
(Raise_Error
);
69 procedure Close
(Port
: in out Serial_Port
) is
70 procedure Unchecked_Free
is
71 new Unchecked_Deallocation
(Port_Data
, Port_Data_Access
);
76 if Port
.H
/= null then
77 Success
:= CloseHandle
(HANDLE
(Port
.H
.all));
78 Unchecked_Free
(Port
.H
);
80 if Success
= Win32
.FALSE then
81 Raise_Error
("error closing the port");
90 function Name
(Number
: Positive) return Port_Name
is
91 N_Img
: constant String := Positive'Image (Number
);
93 return Port_Name
("COM" & N_Img
(N_Img
'First + 1 .. N_Img
'Last) & ':');
101 (Port
: out Serial_Port
;
104 C_Name
: constant String := String (Name
) & ASCII
.NUL
;
106 pragma Unreferenced
(Success
);
109 if Port
.H
= null then
110 Port
.H
:= new Port_Data
;
112 Success
:= CloseHandle
(HANDLE
(Port
.H
.all));
115 Port
.H
.all := CreateFileA
116 (lpFileName
=> C_Name
(C_Name
'First)'Address,
117 dwDesiredAccess
=> GENERIC_READ
or GENERIC_WRITE
,
119 lpSecurityAttributes
=> null,
120 dwCreationDisposition
=> OPEN_EXISTING
,
121 dwFlagsAndAttributes
=> 0,
124 if Port
.H
.all = 0 then
125 Raise_Error
("cannot open com port");
133 procedure Raise_Error
(Message
: String; Error
: DWORD
:= GetLastError
) is
135 raise Serial_Error
with Message
& " (" & DWORD
'Image (Error
) & ')';
142 overriding
procedure Read
143 (Port
: in out Serial_Port
;
144 Buffer
: out Stream_Element_Array
;
145 Last
: out Stream_Element_Offset
)
148 Read_Last
: aliased DWORD
;
151 if Port
.H
= null then
152 Raise_Error
("read: port not opened", 0);
157 (hFile
=> HANDLE
(Port
.H
.all),
158 lpBuffer
=> Buffer
(Buffer
'First)'Address,
159 nNumberOfBytesToRead
=> DWORD
(Buffer
'Length),
160 lpNumberOfBytesRead
=> Read_Last
'Access,
161 lpOverlapped
=> null);
163 if Success
= Win32
.FALSE then
164 Raise_Error
("read error");
167 Last
:= Last_Index
(Buffer
'First, size_t
(Read_Last
));
176 Rate
: Data_Rate
:= B9600
;
177 Bits
: Data_Bits
:= CS8
;
178 Stop_Bits
: Stop_Bits_Number
:= One
;
179 Parity
: Parity_Check
:= None
;
180 Block
: Boolean := True;
181 Local
: Boolean := True;
182 Flow
: Flow_Control
:= None
;
183 Timeout
: Duration := 10.0)
185 pragma Unreferenced
(Local
);
188 Com_Time_Out
: aliased COMMTIMEOUTS
;
189 Com_Settings
: aliased DCB
;
192 if Port
.H
= null then
193 Raise_Error
("set: port not opened", 0);
196 Success
:= GetCommState
(HANDLE
(Port
.H
.all), Com_Settings
'Access);
198 if Success
= Win32
.FALSE then
199 Success
:= CloseHandle
(HANDLE
(Port
.H
.all));
201 Raise_Error
("set: cannot get comm state");
204 Com_Settings
.BaudRate
:= DWORD
(Data_Rate_Value
(Rate
));
205 Com_Settings
.fParity
:= 1;
206 Com_Settings
.fBinary
:= Bits1
(System
.Win32
.TRUE);
207 Com_Settings
.fOutxDsrFlow
:= 0;
208 Com_Settings
.fDsrSensitivity
:= 0;
209 Com_Settings
.fDtrControl
:= OSC
.DTR_CONTROL_ENABLE
;
210 Com_Settings
.fInX
:= 0;
211 Com_Settings
.fRtsControl
:= OSC
.RTS_CONTROL_ENABLE
;
215 Com_Settings
.fOutX
:= 0;
216 Com_Settings
.fOutxCtsFlow
:= 0;
219 Com_Settings
.fOutX
:= 0;
220 Com_Settings
.fOutxCtsFlow
:= 1;
223 Com_Settings
.fOutX
:= 1;
224 Com_Settings
.fOutxCtsFlow
:= 0;
227 Com_Settings
.fAbortOnError
:= 0;
228 Com_Settings
.ByteSize
:= BYTE
(C_Bits
(Bits
));
229 Com_Settings
.Parity
:= BYTE
(C_Parity
(Parity
));
230 Com_Settings
.StopBits
:= BYTE
(C_Stop_Bits
(Stop_Bits
));
232 Success
:= SetCommState
(HANDLE
(Port
.H
.all), Com_Settings
'Access);
234 if Success
= Win32
.FALSE then
235 Success
:= CloseHandle
(HANDLE
(Port
.H
.all));
237 Raise_Error
("cannot set comm state");
240 -- Set the timeout status
243 Com_Time_Out
:= (others => 0);
246 (ReadTotalTimeoutConstant
=> DWORD
(1000 * Timeout
),
252 (hFile
=> HANDLE
(Port
.H
.all),
253 lpCommTimeouts
=> Com_Time_Out
'Access);
255 if Success
= Win32
.FALSE then
256 Raise_Error
("cannot set the timeout");
264 overriding
procedure Write
265 (Port
: in out Serial_Port
;
266 Buffer
: Stream_Element_Array
)
269 Temp_Last
: aliased DWORD
;
272 if Port
.H
= null then
273 Raise_Error
("write: port not opened", 0);
278 (hFile
=> HANDLE
(Port
.H
.all),
279 lpBuffer
=> Buffer
'Address,
280 nNumberOfBytesToWrite
=> DWORD
(Buffer
'Length),
281 lpNumberOfBytesWritten
=> Temp_Last
'Access,
282 lpOverlapped
=> null);
284 if Success
= Win32
.FALSE
285 or else Stream_Element_Offset
(Temp_Last
) /= Buffer
'Length
287 Raise_Error
("failed to write data");
291 end GNAT
.Serial_Communications
;