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 GNU/Linux implementation of this package
36 with Ada
.Streams
; use Ada
.Streams
;
38 with Ada
.Unchecked_Deallocation
;
40 with System
.CRTL
; use System
, System
.CRTL
;
42 with GNAT
.OS_Lib
; use GNAT
.OS_Lib
;
44 package body GNAT
.Serial_Communications
is
46 use type Interfaces
.C
.unsigned
;
48 type Port_Data
is new int
;
50 subtype unsigned
is Interfaces
.C
.unsigned
;
51 subtype char
is Interfaces
.C
.char
;
52 subtype unsigned_char
is Interfaces
.C
.unsigned_char
;
54 function fcntl
(fd
: int
; cmd
: int
; value
: int
) return int
;
55 pragma Import
(C
, fcntl
, "fcntl");
57 O_RDWR
: constant := 8#
02#
;
58 O_NOCTTY
: constant := 8#
0400#
;
59 O_NDELAY
: constant := 8#
04000#
;
60 FNDELAY
: constant := O_NDELAY
;
61 F_SETFL
: constant := 4;
62 TCSANOW
: constant := 0;
63 TCIFLUSH
: constant := 0;
64 CLOCAL
: constant := 8#
04000#
;
65 CREAD
: constant := 8#
0200#
;
66 CSTOPB
: constant := 8#
0100#
;
67 CRTSCTS
: constant := 8#
020000000000#
;
68 PARENB
: constant := 8#
00400#
;
69 PARODD
: constant := 8#
01000#
;
73 VTIME
: constant := 5;
76 C_Data_Rate
: constant array (Data_Rate
) of unsigned
:=
84 B115200
=> 8#
010002#
);
86 C_Bits
: constant array (Data_Bits
) of unsigned
:=
87 (B7
=> 8#
040#
, B8
=> 8#
060#
);
89 C_Stop_Bits
: constant array (Stop_Bits_Number
) of unsigned
:=
90 (One
=> 0, Two
=> CSTOPB
);
92 C_Parity
: constant array (Parity_Check
) of unsigned
:=
93 (None
=> 0, Odd
=> PARENB
or PARODD
, Even
=> PARENB
);
95 procedure Raise_Error
(Message
: String; Error
: Integer := Errno
);
96 pragma No_Return
(Raise_Error
);
102 function Name
(Number
: Positive) return Port_Name
is
103 N
: constant Natural := Number
- 1;
104 N_Img
: constant String := Natural'Image (N
);
106 return Port_Name
("/dev/ttyS" & N_Img
(N_Img
'First + 1 .. N_Img
'Last));
114 (Port
: out Serial_Port
;
117 C_Name
: constant String := String (Name
) & ASCII
.NUL
;
121 if Port
.H
= null then
122 Port
.H
:= new Port_Data
;
125 Port
.H
.all := Port_Data
(open
126 (C_Name
(C_Name
'First)'Address, int
(O_RDWR
+ O_NOCTTY
+ O_NDELAY
)));
128 if Port
.H
.all = -1 then
129 Raise_Error
("open: open failed");
132 -- By default we are in blocking mode
134 Res
:= fcntl
(int
(Port
.H
.all), F_SETFL
, 0);
137 Raise_Error
("open: fcntl failed");
145 procedure Raise_Error
(Message
: String; Error
: Integer := Errno
) is
147 raise Serial_Error
with Message
& " (" & Integer'Image (Error
) & ')';
154 overriding
procedure Read
155 (Port
: in out Serial_Port
;
156 Buffer
: out Stream_Element_Array
;
157 Last
: out Stream_Element_Offset
)
159 Len
: constant int
:= Buffer
'Length;
163 if Port
.H
= null then
164 Raise_Error
("read: port not opened", 0);
167 Res
:= read
(Integer (Port
.H
.all), Buffer
'Address, Len
);
171 Raise_Error
("read failed");
173 Last
:= Buffer
'First + Stream_Element_Offset
(Res
) - 1;
183 Rate
: Data_Rate
:= B9600
;
184 Bits
: Data_Bits
:= B8
;
185 Stop_Bits
: Stop_Bits_Number
:= One
;
186 Parity
: Parity_Check
:= None
;
187 Block
: Boolean := True;
188 Timeout
: Duration := 10.0)
190 type termios
is record
195 c_line
: unsigned_char
;
196 c_cc
: Interfaces
.C
.char_array
(0 .. 31);
200 pragma Convention
(C
, termios
);
202 function tcgetattr
(fd
: int
; termios_p
: Address
) return int
;
203 pragma Import
(C
, tcgetattr
, "tcgetattr");
206 (fd
: int
; action
: int
; termios_p
: Address
) return int
;
207 pragma Import
(C
, tcsetattr
, "tcsetattr");
209 function tcflush
(fd
: int
; queue_selector
: int
) return int
;
210 pragma Import
(C
, tcflush
, "tcflush");
216 if Port
.H
= null then
217 Raise_Error
("set: port not opened", 0);
220 -- Get current port settings
222 Res
:= tcgetattr
(int
(Port
.H
.all), Current
'Address);
224 -- Change settings now
226 Current
.c_cflag
:= C_Data_Rate
(Rate
)
228 or C_Stop_Bits
(Stop_Bits
)
233 Current
.c_lflag
:= 0;
234 Current
.c_iflag
:= 0;
235 Current
.c_oflag
:= 0;
236 Current
.c_ispeed
:= Data_Rate_Value
(Rate
);
237 Current
.c_ospeed
:= Data_Rate_Value
(Rate
);
238 Current
.c_cc
(VMIN
) := char
'Val (0);
239 Current
.c_cc
(VTIME
) := char
'Val (Natural (Timeout
* 10));
243 Res
:= tcflush
(int
(Port
.H
.all), TCIFLUSH
);
244 Res
:= tcsetattr
(int
(Port
.H
.all), TCSANOW
, Current
'Address);
249 Res
:= fcntl
(int
(Port
.H
.all), F_SETFL
, 0);
251 Res
:= fcntl
(int
(Port
.H
.all), F_SETFL
, 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 int
:= 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
);
276 pragma Assert
(Res
= Len
);
279 Raise_Error
("write failed");
287 procedure Close
(Port
: in out Serial_Port
) is
288 procedure Unchecked_Free
is
289 new Unchecked_Deallocation
(Port_Data
, Port_Data_Access
);
292 pragma Unreferenced
(Res
);
295 if Port
.H
/= null then
296 Res
:= close
(int
(Port
.H
.all));
297 Unchecked_Free
(Port
.H
);
301 end GNAT
.Serial_Communications
;