OSDN Git Service

Daily bump.
[pf3gnuchains/gcc-fork.git] / gcc / ada / g-sercom-linux.adb
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-2010, 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
42 with GNAT.OS_Lib; use GNAT.OS_Lib;
43
44 package body GNAT.Serial_Communications is
45
46    use type Interfaces.C.unsigned;
47
48    type Port_Data is new int;
49
50    subtype unsigned is Interfaces.C.unsigned;
51    subtype char is Interfaces.C.char;
52    subtype unsigned_char is Interfaces.C.unsigned_char;
53
54    function fcntl (fd : int; cmd : int; value : int) return int;
55    pragma Import (C, fcntl, "fcntl");
56
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#;
70
71    --  c_cc indexes
72
73    VTIME : constant := 5;
74    VMIN  : constant := 6;
75
76    C_Data_Rate : constant array (Data_Rate) of unsigned :=
77                    (B1200   => 8#000011#,
78                     B2400   => 8#000013#,
79                     B4800   => 8#000014#,
80                     B9600   => 8#000015#,
81                     B19200  => 8#000016#,
82                     B38400  => 8#000017#,
83                     B57600  => 8#010001#,
84                     B115200 => 8#010002#);
85
86    C_Bits      : constant array (Data_Bits) of unsigned :=
87                    (CS7 => 8#040#, CS8 => 8#060#);
88
89    C_Stop_Bits : constant array (Stop_Bits_Number) of unsigned :=
90                    (One => 0, Two => CSTOPB);
91
92    C_Parity    : constant array (Parity_Check) of unsigned :=
93                    (None => 0, Odd => PARENB or PARODD, Even => PARENB);
94
95    procedure Raise_Error (Message : String; Error : Integer := Errno);
96    pragma No_Return (Raise_Error);
97
98    ----------
99    -- Name --
100    ----------
101
102    function Name (Number : Positive) return Port_Name is
103       N     : constant Natural := Number - 1;
104       N_Img : constant String  := Natural'Image (N);
105    begin
106       return Port_Name ("/dev/ttyS" & N_Img (N_Img'First + 1 .. N_Img'Last));
107    end Name;
108
109    ----------
110    -- Open --
111    ----------
112
113    procedure Open
114      (Port : out Serial_Port;
115       Name : Port_Name)
116    is
117       C_Name : constant String := String (Name) & ASCII.NUL;
118       Res    : int;
119
120    begin
121       if Port.H = null then
122          Port.H := new Port_Data;
123       end if;
124
125       Port.H.all := Port_Data (open
126          (C_Name (C_Name'First)'Address, int (O_RDWR + O_NOCTTY + O_NDELAY)));
127
128       if Port.H.all = -1 then
129          Raise_Error ("open: open failed");
130       end if;
131
132       --  By default we are in blocking mode
133
134       Res := fcntl (int (Port.H.all), F_SETFL, 0);
135
136       if Res = -1 then
137          Raise_Error ("open: fcntl failed");
138       end if;
139    end Open;
140
141    -----------------
142    -- Raise_Error --
143    -----------------
144
145    procedure Raise_Error (Message : String; Error : Integer := Errno) is
146    begin
147       raise Serial_Error with Message & " (" & Integer'Image (Error) & ')';
148    end Raise_Error;
149
150    ----------
151    -- Read --
152    ----------
153
154    overriding procedure Read
155      (Port   : in out Serial_Port;
156       Buffer : out Stream_Element_Array;
157       Last   : out Stream_Element_Offset)
158    is
159       Len : constant size_t := Buffer'Length;
160       Res : ssize_t;
161
162    begin
163       if Port.H = null then
164          Raise_Error ("read: port not opened", 0);
165       end if;
166
167       Res := read (Integer (Port.H.all), Buffer'Address, Len);
168
169       if Res = -1 then
170          Raise_Error ("read failed");
171       end if;
172
173       Last := Last_Index (Buffer'First, size_t (Res));
174    end Read;
175
176    ---------
177    -- Set --
178    ---------
179
180    procedure Set
181      (Port      : Serial_Port;
182       Rate      : Data_Rate        := B9600;
183       Bits      : Data_Bits        := CS8;
184       Stop_Bits : Stop_Bits_Number := One;
185       Parity    : Parity_Check     := None;
186       Block     : Boolean          := True;
187       Timeout   : Duration         := 10.0)
188    is
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 CLOCAL
233                                 or CREAD
234                                 or CRTSCTS;
235       Current.c_lflag      := 0;
236       Current.c_iflag      := 0;
237       Current.c_oflag      := 0;
238       Current.c_ispeed     := Data_Rate_Value (Rate);
239       Current.c_ospeed     := Data_Rate_Value (Rate);
240       Current.c_cc (VMIN)  := char'Val (0);
241       Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10));
242
243       --  Set port settings
244
245       Res := tcflush (int (Port.H.all), TCIFLUSH);
246       Res := tcsetattr (int (Port.H.all), TCSANOW, Current'Address);
247
248       --  Block
249
250       Res := fcntl (int (Port.H.all), F_SETFL, (if Block then 0 else FNDELAY));
251
252       if Res = -1 then
253          Raise_Error ("set: fcntl failed");
254       end if;
255    end Set;
256
257    -----------
258    -- Write --
259    -----------
260
261    overriding procedure Write
262      (Port   : in out Serial_Port;
263       Buffer : Stream_Element_Array)
264    is
265       Len : constant size_t := Buffer'Length;
266       Res : ssize_t;
267
268    begin
269       if Port.H = null then
270          Raise_Error ("write: port not opened", 0);
271       end if;
272
273       Res := write (int (Port.H.all), Buffer'Address, Len);
274
275       if Res = -1 then
276          Raise_Error ("write failed");
277       end if;
278
279       pragma Assert (size_t (Res) = Len);
280    end Write;
281
282    -----------
283    -- Close --
284    -----------
285
286    procedure Close (Port : in out Serial_Port) is
287       procedure Unchecked_Free is
288         new Unchecked_Deallocation (Port_Data, Port_Data_Access);
289
290       Res : int;
291       pragma Unreferenced (Res);
292
293    begin
294       if Port.H /= null then
295          Res := close (int (Port.H.all));
296          Unchecked_Free (Port.H);
297       end if;
298    end Close;
299
300 end GNAT.Serial_Communications;