Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/g-sercom__linux.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
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 -- --
9 -- Copyright (C) 2007-2017, AdaCore --
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;