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-2009, 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 GNU/Linux implementation of this package
36 with Ada
.Streams
; use Ada
.Streams
;
38 with Ada
.Unchecked_Deallocation
;
40 with System
; use System
;
41 with System
.Communication
; use System
.Communication
;
42 with System
.CRTL
; use System
.CRTL
;
44 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
46 package body GNAT
.Serial_Communications
is
48 use type Interfaces
.C
.unsigned
;
50 type Port_Data
is new int
;
52 subtype unsigned
is Interfaces
.C
.unsigned
;
53 subtype char
is Interfaces
.C
.char
;
54 subtype unsigned_char
is Interfaces
.C
.unsigned_char
;
56 function fcntl
(fd
: int
; cmd
: int
; value
: int
) return int
;
57 pragma Import
(C
, fcntl
, "fcntl");
59 O_RDWR
: constant := 8#
02#
;
60 O_NOCTTY
: constant := 8#
0400#
;
61 O_NDELAY
: constant := 8#
04000#
;
62 FNDELAY
: constant := O_NDELAY
;
63 F_SETFL
: constant := 4;
64 TCSANOW
: constant := 0;
65 TCIFLUSH
: constant := 0;
66 CLOCAL
: constant := 8#
04000#
;
67 CREAD
: constant := 8#
0200#
;
68 CSTOPB
: constant := 8#
0100#
;
69 CRTSCTS
: constant := 8#
020000000000#
;
70 PARENB
: constant := 8#
00400#
;
71 PARODD
: constant := 8#
01000#
;
75 VTIME
: constant := 5;
78 C_Data_Rate
: constant array (Data_Rate
) of unsigned
:=
86 B115200
=> 8#
010002#
);
88 C_Bits
: constant array (Data_Bits
) of unsigned
:=
89 (CS7
=> 8#
040#
, CS8
=> 8#
060#
);
91 C_Stop_Bits
: constant array (Stop_Bits_Number
) of unsigned
:=
92 (One
=> 0, Two
=> CSTOPB
);
94 C_Parity
: constant array (Parity_Check
) of unsigned
:=
95 (None
=> 0, Odd
=> PARENB
or PARODD
, Even
=> PARENB
);
97 procedure Raise_Error
(Message
: String; Error
: Integer := Errno
);
98 pragma No_Return
(Raise_Error
);
104 function Name
(Number
: Positive) return Port_Name
is
105 N
: constant Natural := Number
- 1;
106 N_Img
: constant String := Natural'Image (N
);
108 return Port_Name
("/dev/ttyS" & N_Img
(N_Img
'First + 1 .. N_Img
'Last));
116 (Port
: out Serial_Port
;
119 C_Name
: constant String := String (Name
) & ASCII
.NUL
;
123 if Port
.H
= null then
124 Port
.H
:= new Port_Data
;
127 Port
.H
.all := Port_Data
(open
128 (C_Name
(C_Name
'First)'Address, int
(O_RDWR
+ O_NOCTTY
+ O_NDELAY
)));
130 if Port
.H
.all = -1 then
131 Raise_Error
("open: open failed");
134 -- By default we are in blocking mode
136 Res
:= fcntl
(int
(Port
.H
.all), F_SETFL
, 0);
139 Raise_Error
("open: fcntl failed");
147 procedure Raise_Error
(Message
: String; Error
: Integer := Errno
) is
149 raise Serial_Error
with Message
& " (" & Integer'Image (Error
) & ')';
156 overriding
procedure Read
157 (Port
: in out Serial_Port
;
158 Buffer
: out Stream_Element_Array
;
159 Last
: out Stream_Element_Offset
)
161 Len
: constant size_t
:= Buffer
'Length;
165 if Port
.H
= null then
166 Raise_Error
("read: port not opened", 0);
169 Res
:= read
(Integer (Port
.H
.all), Buffer
'Address, Len
);
172 Raise_Error
("read failed");
175 Last
:= Last_Index
(Buffer
'First, size_t
(Res
));
184 Rate
: Data_Rate
:= B9600
;
185 Bits
: Data_Bits
:= CS8
;
186 Stop_Bits
: Stop_Bits_Number
:= One
;
187 Parity
: Parity_Check
:= None
;
188 Block
: Boolean := True;
189 Timeout
: Duration := 10.0)
191 type termios
is record
196 c_line
: unsigned_char
;
197 c_cc
: Interfaces
.C
.char_array
(0 .. 31);
201 pragma Convention
(C
, termios
);
203 function tcgetattr
(fd
: int
; termios_p
: Address
) return int
;
204 pragma Import
(C
, tcgetattr
, "tcgetattr");
207 (fd
: int
; action
: int
; termios_p
: Address
) return int
;
208 pragma Import
(C
, tcsetattr
, "tcsetattr");
210 function tcflush
(fd
: int
; queue_selector
: int
) return int
;
211 pragma Import
(C
, tcflush
, "tcflush");
216 pragma Warnings
(Off
, Res
);
217 -- Warnings off, since we don't always test the result
220 if Port
.H
= null then
221 Raise_Error
("set: port not opened", 0);
224 -- Get current port settings
226 Res
:= tcgetattr
(int
(Port
.H
.all), Current
'Address);
228 -- Change settings now
230 Current
.c_cflag
:= C_Data_Rate
(Rate
)
232 or C_Stop_Bits
(Stop_Bits
)
237 Current
.c_lflag
:= 0;
238 Current
.c_iflag
:= 0;
239 Current
.c_oflag
:= 0;
240 Current
.c_ispeed
:= Data_Rate_Value
(Rate
);
241 Current
.c_ospeed
:= Data_Rate_Value
(Rate
);
242 Current
.c_cc
(VMIN
) := char
'Val (0);
243 Current
.c_cc
(VTIME
) := char
'Val (Natural (Timeout
* 10));
247 Res
:= tcflush
(int
(Port
.H
.all), TCIFLUSH
);
248 Res
:= tcsetattr
(int
(Port
.H
.all), TCSANOW
, Current
'Address);
252 Res
:= fcntl
(int
(Port
.H
.all), F_SETFL
, (if Block
then 0 else FNDELAY
));
255 Raise_Error
("set: fcntl failed");
263 overriding
procedure Write
264 (Port
: in out Serial_Port
;
265 Buffer
: Stream_Element_Array
)
267 Len
: constant size_t
:= Buffer
'Length;
271 if Port
.H
= null then
272 Raise_Error
("write: port not opened", 0);
275 Res
:= write
(int
(Port
.H
.all), Buffer
'Address, Len
);
278 Raise_Error
("write failed");
281 pragma Assert
(size_t
(Res
) = Len
);
288 procedure Close
(Port
: in out Serial_Port
) is
289 procedure Unchecked_Free
is
290 new Unchecked_Deallocation
(Port_Data
, Port_Data_Access
);
293 pragma Unreferenced
(Res
);
296 if Port
.H
/= null then
297 Res
:= close
(int
(Port
.H
.all));
298 Unchecked_Free
(Port
.H
);
302 end GNAT
.Serial_Communications
;