|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT COMPILER COMPONENTS --
|
|
|
4 -- --
|
|
|
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 --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 2007-2018, AdaCore --
|
|
111
|
10 -- --
|
|
|
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. --
|
|
|
17 -- --
|
|
|
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. --
|
|
|
21 -- --
|
|
|
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/>. --
|
|
|
26 -- --
|
|
|
27 -- GNAT was originally developed by the GNAT team at New York University. --
|
|
|
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
|
29 -- --
|
|
|
30 ------------------------------------------------------------------------------
|
|
|
31
|
|
|
32 -- This is the GNU/Linux implementation of this package
|
|
|
33
|
|
|
34 with Ada.Streams; use Ada.Streams;
|
|
|
35 with Ada; use Ada;
|
|
|
36 with Ada.Unchecked_Deallocation;
|
|
|
37
|
|
|
38 with System; use System;
|
|
|
39 with System.Communication; use System.Communication;
|
|
|
40 with System.CRTL; use System.CRTL;
|
|
|
41 with System.OS_Constants;
|
|
|
42
|
|
|
43 with GNAT.OS_Lib; use GNAT.OS_Lib;
|
|
|
44
|
|
|
45 package body GNAT.Serial_Communications is
|
|
|
46
|
|
|
47 package OSC renames System.OS_Constants;
|
|
|
48
|
|
|
49 use type Interfaces.C.unsigned;
|
|
|
50
|
|
|
51 type Port_Data is new int;
|
|
|
52
|
|
|
53 subtype unsigned is Interfaces.C.unsigned;
|
|
|
54 subtype char is Interfaces.C.char;
|
|
|
55 subtype unsigned_char is Interfaces.C.unsigned_char;
|
|
|
56
|
|
|
57 function fcntl (fd : int; cmd : int; value : int) return int;
|
|
|
58 pragma Import (C, fcntl, "fcntl");
|
|
|
59
|
|
|
60 C_Data_Rate : constant array (Data_Rate) of unsigned :=
|
|
|
61 (B75 => OSC.B75,
|
|
|
62 B110 => OSC.B110,
|
|
|
63 B150 => OSC.B150,
|
|
|
64 B300 => OSC.B300,
|
|
|
65 B600 => OSC.B600,
|
|
|
66 B1200 => OSC.B1200,
|
|
|
67 B2400 => OSC.B2400,
|
|
|
68 B4800 => OSC.B4800,
|
|
|
69 B9600 => OSC.B9600,
|
|
|
70 B19200 => OSC.B19200,
|
|
|
71 B38400 => OSC.B38400,
|
|
|
72 B57600 => OSC.B57600,
|
|
|
73 B115200 => OSC.B115200);
|
|
|
74
|
|
|
75 C_Bits : constant array (Data_Bits) of unsigned :=
|
|
|
76 (CS7 => OSC.CS7, CS8 => OSC.CS8);
|
|
|
77
|
|
|
78 C_Stop_Bits : constant array (Stop_Bits_Number) of unsigned :=
|
|
|
79 (One => 0, Two => OSC.CSTOPB);
|
|
|
80
|
|
|
81 C_Parity : constant array (Parity_Check) of unsigned :=
|
|
|
82 (None => 0,
|
|
|
83 Odd => OSC.PARENB or OSC.PARODD,
|
|
|
84 Even => OSC.PARENB);
|
|
|
85
|
|
|
86 procedure Raise_Error (Message : String; Error : Integer := Errno);
|
|
|
87 pragma No_Return (Raise_Error);
|
|
|
88
|
|
|
89 ----------
|
|
|
90 -- Name --
|
|
|
91 ----------
|
|
|
92
|
|
|
93 function Name (Number : Positive) return Port_Name is
|
|
|
94 N : constant Natural := Number - 1;
|
|
|
95 N_Img : constant String := Natural'Image (N);
|
|
|
96 begin
|
|
|
97 return Port_Name ("/dev/ttyS" & N_Img (N_Img'First + 1 .. N_Img'Last));
|
|
|
98 end Name;
|
|
|
99
|
|
|
100 ----------
|
|
|
101 -- Open --
|
|
|
102 ----------
|
|
|
103
|
|
|
104 procedure Open
|
|
|
105 (Port : out Serial_Port;
|
|
|
106 Name : Port_Name)
|
|
|
107 is
|
|
|
108 use OSC;
|
|
|
109
|
|
|
110 C_Name : constant String := String (Name) & ASCII.NUL;
|
|
|
111 Res : int;
|
|
|
112
|
|
|
113 begin
|
|
|
114 if Port.H = null then
|
|
|
115 Port.H := new Port_Data;
|
|
|
116 end if;
|
|
|
117
|
|
|
118 Port.H.all := Port_Data (open
|
|
|
119 (C_Name (C_Name'First)'Address, int (O_RDWR + O_NOCTTY + O_NDELAY)));
|
|
|
120
|
|
|
121 if Port.H.all = -1 then
|
|
|
122 Raise_Error ("open: open failed");
|
|
|
123 end if;
|
|
|
124
|
|
|
125 -- By default we are in blocking mode
|
|
|
126
|
|
|
127 Res := fcntl (int (Port.H.all), F_SETFL, 0);
|
|
|
128
|
|
|
129 if Res = -1 then
|
|
|
130 Raise_Error ("open: fcntl failed");
|
|
|
131 end if;
|
|
|
132 end Open;
|
|
|
133
|
|
|
134 -----------------
|
|
|
135 -- Raise_Error --
|
|
|
136 -----------------
|
|
|
137
|
|
|
138 procedure Raise_Error (Message : String; Error : Integer := Errno) is
|
|
|
139 begin
|
|
|
140 raise Serial_Error with Message
|
|
|
141 & (if Error /= 0
|
|
|
142 then " (" & Errno_Message (Err => Error) & ')'
|
|
|
143 else "");
|
|
|
144 end Raise_Error;
|
|
|
145
|
|
|
146 ----------
|
|
|
147 -- Read --
|
|
|
148 ----------
|
|
|
149
|
|
|
150 overriding procedure Read
|
|
|
151 (Port : in out Serial_Port;
|
|
|
152 Buffer : out Stream_Element_Array;
|
|
|
153 Last : out Stream_Element_Offset)
|
|
|
154 is
|
|
|
155 Len : constant size_t := Buffer'Length;
|
|
|
156 Res : ssize_t;
|
|
|
157
|
|
|
158 begin
|
|
|
159 if Port.H = null then
|
|
|
160 Raise_Error ("read: port not opened", 0);
|
|
|
161 end if;
|
|
|
162
|
|
|
163 Res := read (Integer (Port.H.all), Buffer'Address, Len);
|
|
|
164
|
|
|
165 if Res = -1 then
|
|
|
166 Raise_Error ("read failed");
|
|
|
167 end if;
|
|
|
168
|
|
|
169 Last := Last_Index (Buffer'First, size_t (Res));
|
|
|
170 end Read;
|
|
|
171
|
|
|
172 ---------
|
|
|
173 -- Set --
|
|
|
174 ---------
|
|
|
175
|
|
|
176 procedure Set
|
|
|
177 (Port : Serial_Port;
|
|
|
178 Rate : Data_Rate := B9600;
|
|
|
179 Bits : Data_Bits := CS8;
|
|
|
180 Stop_Bits : Stop_Bits_Number := One;
|
|
|
181 Parity : Parity_Check := None;
|
|
|
182 Block : Boolean := True;
|
|
|
183 Local : Boolean := True;
|
|
|
184 Flow : Flow_Control := None;
|
|
|
185 Timeout : Duration := 10.0)
|
|
|
186 is
|
|
|
187 use OSC;
|
|
|
188
|
|
|
189 type termios is record
|
|
|
190 c_iflag : unsigned;
|
|
|
191 c_oflag : unsigned;
|
|
|
192 c_cflag : unsigned;
|
|
|
193 c_lflag : unsigned;
|
|
|
194 c_line : unsigned_char;
|
|
|
195 c_cc : Interfaces.C.char_array (0 .. 31);
|
|
|
196 c_ispeed : unsigned;
|
|
|
197 c_ospeed : unsigned;
|
|
|
198 end record;
|
|
|
199 pragma Convention (C, termios);
|
|
|
200
|
|
|
201 function tcgetattr (fd : int; termios_p : Address) return int;
|
|
|
202 pragma Import (C, tcgetattr, "tcgetattr");
|
|
|
203
|
|
|
204 function tcsetattr
|
|
|
205 (fd : int; action : int; termios_p : Address) return int;
|
|
|
206 pragma Import (C, tcsetattr, "tcsetattr");
|
|
|
207
|
|
|
208 function tcflush (fd : int; queue_selector : int) return int;
|
|
|
209 pragma Import (C, tcflush, "tcflush");
|
|
|
210
|
|
|
211 Current : termios;
|
|
|
212
|
|
|
213 Res : int;
|
|
|
214 pragma Warnings (Off, Res);
|
|
|
215 -- Warnings off, since we don't always test the result
|
|
|
216
|
|
|
217 begin
|
|
|
218 if Port.H = null then
|
|
|
219 Raise_Error ("set: port not opened", 0);
|
|
|
220 end if;
|
|
|
221
|
|
|
222 -- Get current port settings
|
|
|
223
|
|
|
224 Res := tcgetattr (int (Port.H.all), Current'Address);
|
|
|
225
|
|
|
226 -- Change settings now
|
|
|
227
|
|
|
228 Current.c_cflag := C_Data_Rate (Rate)
|
|
|
229 or C_Bits (Bits)
|
|
|
230 or C_Stop_Bits (Stop_Bits)
|
|
|
231 or C_Parity (Parity)
|
|
|
232 or CREAD;
|
|
|
233 Current.c_iflag := 0;
|
|
|
234 Current.c_lflag := 0;
|
|
|
235 Current.c_oflag := 0;
|
|
|
236
|
|
|
237 if Local then
|
|
|
238 Current.c_cflag := Current.c_cflag or CLOCAL;
|
|
|
239 end if;
|
|
|
240
|
|
|
241 case Flow is
|
|
|
242 when None =>
|
|
|
243 null;
|
|
|
244
|
|
|
245 when RTS_CTS =>
|
|
|
246 Current.c_cflag := Current.c_cflag or CRTSCTS;
|
|
|
247
|
|
|
248 when Xon_Xoff =>
|
|
|
249 Current.c_iflag := Current.c_iflag or IXON;
|
|
|
250 end case;
|
|
|
251
|
|
|
252 Current.c_ispeed := Data_Rate_Value (Rate);
|
|
|
253 Current.c_ospeed := Data_Rate_Value (Rate);
|
|
|
254 Current.c_cc (VMIN) := char'Val (0);
|
|
|
255 Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10));
|
|
|
256
|
|
|
257 -- Set port settings
|
|
|
258
|
|
|
259 Res := tcflush (int (Port.H.all), TCIFLUSH);
|
|
|
260 Res := tcsetattr (int (Port.H.all), TCSANOW, Current'Address);
|
|
|
261
|
|
|
262 -- Block
|
|
|
263
|
|
|
264 Res := fcntl (int (Port.H.all), F_SETFL, (if Block then 0 else FNDELAY));
|
|
|
265
|
|
|
266 if Res = -1 then
|
|
|
267 Raise_Error ("set: fcntl failed");
|
|
|
268 end if;
|
|
|
269 end Set;
|
|
|
270
|
|
|
271 -----------
|
|
|
272 -- Write --
|
|
|
273 -----------
|
|
|
274
|
|
|
275 overriding procedure Write
|
|
|
276 (Port : in out Serial_Port;
|
|
|
277 Buffer : Stream_Element_Array)
|
|
|
278 is
|
|
|
279 Len : constant size_t := Buffer'Length;
|
|
|
280 Res : ssize_t;
|
|
|
281
|
|
|
282 begin
|
|
|
283 if Port.H = null then
|
|
|
284 Raise_Error ("write: port not opened", 0);
|
|
|
285 end if;
|
|
|
286
|
|
|
287 Res := write (int (Port.H.all), Buffer'Address, Len);
|
|
|
288
|
|
|
289 if Res = -1 then
|
|
|
290 Raise_Error ("write failed");
|
|
|
291 end if;
|
|
|
292
|
|
|
293 pragma Assert (size_t (Res) = Len);
|
|
|
294 end Write;
|
|
|
295
|
|
|
296 -----------
|
|
|
297 -- Close --
|
|
|
298 -----------
|
|
|
299
|
|
|
300 procedure Close (Port : in out Serial_Port) is
|
|
|
301 procedure Unchecked_Free is
|
|
|
302 new Unchecked_Deallocation (Port_Data, Port_Data_Access);
|
|
|
303
|
|
|
304 Res : int;
|
|
|
305 pragma Unreferenced (Res);
|
|
|
306
|
|
|
307 begin
|
|
|
308 if Port.H /= null then
|
|
|
309 Res := close (int (Port.H.all));
|
|
|
310 Unchecked_Free (Port.H);
|
|
|
311 end if;
|
|
|
312 end Close;
|
|
|
313
|
|
|
314 end GNAT.Serial_Communications;
|
