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-2008, 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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNAT was originally developed by the GNAT team at New York University. --
30 -- Extensive contributions were provided by Ada Core Technologies Inc. --
32 ------------------------------------------------------------------------------
34 -- This is the Windows implementation of this package
36 with Ada
.Unchecked_Deallocation
; use Ada
;
37 with Ada
.Streams
; use Ada
.Streams
;
38 with System
.Win32
.Ext
; use System
, System
.Win32
, System
.Win32
.Ext
;
40 package body GNAT
.Serial_Communications
is
44 type Port_Data
is new HANDLE
;
46 C_Bits
: constant array (Data_Bits
) of Interfaces
.C
.unsigned
:= (8, 7);
47 C_Parity
: constant array (Parity_Check
) of Interfaces
.C
.unsigned
:=
48 (None
=> NOPARITY
, Odd
=> ODDPARITY
, Even
=> EVENPARITY
);
49 C_Stop_Bits
: constant array (Stop_Bits_Number
) of Interfaces
.C
.unsigned
:=
50 (One
=> ONESTOPBIT
, Two
=> TWOSTOPBITS
);
56 procedure Raise_Error
(Message
: String; Error
: DWORD
:= GetLastError
);
57 pragma No_Return
(Raise_Error
);
63 procedure Close
(Port
: in out Serial_Port
) is
64 procedure Unchecked_Free
is
65 new Unchecked_Deallocation
(Port_Data
, Port_Data_Access
);
70 if Port
.H
/= null then
71 Success
:= CloseHandle
(HANDLE
(Port
.H
.all));
72 Unchecked_Free
(Port
.H
);
74 if Success
= Win32
.FALSE then
75 Raise_Error
("error closing the port");
84 function Name
(Number
: Positive) return Port_Name
is
85 N_Img
: constant String := Positive'Image (Number
);
87 return Port_Name
("COM" & N_Img
(N_Img
'First + 1 .. N_Img
'Last) & ':');
95 (Port
: out Serial_Port
;
98 C_Name
: constant String := String (Name
) & ASCII
.NUL
;
100 pragma Unreferenced
(Success
);
103 if Port
.H
= null then
104 Port
.H
:= new Port_Data
;
106 Success
:= CloseHandle
(HANDLE
(Port
.H
.all));
109 Port
.H
.all := CreateFileA
110 (lpFileName
=> C_Name
(C_Name
'First)'Address,
111 dwDesiredAccess
=> GENERIC_READ
or GENERIC_WRITE
,
113 lpSecurityAttributes
=> null,
114 dwCreationDisposition
=> OPEN_EXISTING
,
115 dwFlagsAndAttributes
=> 0,
118 if Port
.H
.all = 0 then
119 Raise_Error
("cannot open com port");
127 procedure Raise_Error
(Message
: String; Error
: DWORD
:= GetLastError
) is
129 raise Serial_Error
with Message
& " (" & DWORD
'Image (Error
) & ')';
136 overriding
procedure Read
137 (Port
: in out Serial_Port
;
138 Buffer
: out Stream_Element_Array
;
139 Last
: out Stream_Element_Offset
)
142 Read_Last
: aliased DWORD
;
145 if Port
.H
= null then
146 Raise_Error
("read: port not opened", 0);
151 (hFile
=> HANDLE
(Port
.H
.all),
152 lpBuffer
=> Buffer
(Buffer
'First)'Address,
153 nNumberOfBytesToRead
=> DWORD
(Buffer
'Length),
154 lpNumberOfBytesRead
=> Read_Last
'Access,
155 lpOverlapped
=> null);
157 if Success
= Win32
.FALSE then
158 Raise_Error
("read error");
161 Last
:= Buffer
'First - 1 + Stream_Element_Offset
(Read_Last
);
170 Rate
: Data_Rate
:= B9600
;
171 Bits
: Data_Bits
:= CS8
;
172 Stop_Bits
: Stop_Bits_Number
:= One
;
173 Parity
: Parity_Check
:= None
;
174 Block
: Boolean := True;
175 Timeout
: Duration := 10.0)
178 Com_Time_Out
: aliased COMMTIMEOUTS
;
179 Com_Settings
: aliased DCB
;
182 if Port
.H
= null then
183 Raise_Error
("set: port not opened", 0);
186 Success
:= GetCommState
(HANDLE
(Port
.H
.all), Com_Settings
'Access);
188 if Success
= Win32
.FALSE then
189 Success
:= CloseHandle
(HANDLE
(Port
.H
.all));
191 Raise_Error
("set: cannot get comm state");
194 Com_Settings
.BaudRate
:= DWORD
(Data_Rate_Value
(Rate
));
195 Com_Settings
.fParity
:= 1;
196 Com_Settings
.fBinary
:= Bits1
(System
.Win32
.TRUE);
197 Com_Settings
.fOutxCtsFlow
:= 0;
198 Com_Settings
.fOutxDsrFlow
:= 0;
199 Com_Settings
.fDsrSensitivity
:= 0;
200 Com_Settings
.fDtrControl
:= DTR_CONTROL_DISABLE
;
201 Com_Settings
.fOutX
:= 0;
202 Com_Settings
.fInX
:= 0;
203 Com_Settings
.fRtsControl
:= RTS_CONTROL_DISABLE
;
204 Com_Settings
.fAbortOnError
:= 0;
205 Com_Settings
.ByteSize
:= BYTE
(C_Bits
(Bits
));
206 Com_Settings
.Parity
:= BYTE
(C_Parity
(Parity
));
207 Com_Settings
.StopBits
:= BYTE
(C_Stop_Bits
(Stop_Bits
));
209 Success
:= SetCommState
(HANDLE
(Port
.H
.all), Com_Settings
'Access);
211 if Success
= Win32
.FALSE then
212 Success
:= CloseHandle
(HANDLE
(Port
.H
.all));
214 Raise_Error
("cannot set comm state");
217 -- Set the timeout status
220 Com_Time_Out
:= (others => 0);
223 (ReadTotalTimeoutConstant
=> DWORD
(1000 * Timeout
),
229 (hFile
=> HANDLE
(Port
.H
.all),
230 lpCommTimeouts
=> Com_Time_Out
'Access);
232 if Success
= Win32
.FALSE then
233 Raise_Error
("cannot set the timeout");
241 overriding
procedure Write
242 (Port
: in out Serial_Port
;
243 Buffer
: Stream_Element_Array
)
246 Temp_Last
: aliased DWORD
;
249 if Port
.H
= null then
250 Raise_Error
("write: port not opened", 0);
255 (hFile
=> HANDLE
(Port
.H
.all),
256 lpBuffer
=> Buffer
'Address,
257 nNumberOfBytesToWrite
=> DWORD
(Buffer
'Length),
258 lpNumberOfBytesWritten
=> Temp_Last
'Access,
259 lpOverlapped
=> null);
261 if Success
= Win32
.FALSE
262 or else Stream_Element_Offset
(Temp_Last
) /= Buffer
'Length
264 Raise_Error
("failed to write data");
268 end GNAT
.Serial_Communications
;