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-2015, 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          when RTS_CTS  =>
 245             Current.c_cflag := Current.c_cflag or CRTSCTS;
 246          when Xon_Xoff =>
 247             Current.c_iflag := Current.c_iflag or IXON;
 248       end case;
 249
 250       Current.c_ispeed     := Data_Rate_Value (Rate);
 251       Current.c_ospeed     := Data_Rate_Value (Rate);
 252       Current.c_cc (VMIN)  := char'Val (0);
 253       Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10));
 254
 255       --  Set port settings
 256
 257       Res := tcflush (int (Port.H.all), TCIFLUSH);
 258       Res := tcsetattr (int (Port.H.all), TCSANOW, Current'Address);
 259
 260       --  Block
 261
 262       Res := fcntl (int (Port.H.all), F_SETFL, (if Block then 0 else FNDELAY));
 263
 264       if Res = -1 then
 265          Raise_Error ("set: fcntl failed");
 266       end if;
 267    end Set;
 268
 269    -----------
 270    -- Write --
 271    -----------
 272
 273    overriding procedure Write
 274      (Port   : in out Serial_Port;
 275       Buffer : Stream_Element_Array)
 276    is
 277       Len : constant size_t := Buffer'Length;
 278       Res : ssize_t;
 279
 280    begin
 281       if Port.H = null then
 282          Raise_Error ("write: port not opened", 0);
 283       end if;
 284
 285       Res := write (int (Port.H.all), Buffer'Address, Len);
 286
 287       if Res = -1 then
 288          Raise_Error ("write failed");
 289       end if;
 290
 291       pragma Assert (size_t (Res) = Len);
 292    end Write;
 293
 294    -----------
 295    -- Close --
 296    -----------
 297
 298    procedure Close (Port : in out Serial_Port) is
 299       procedure Unchecked_Free is
 300         new Unchecked_Deallocation (Port_Data, Port_Data_Access);
 301
 302       Res : int;
 303       pragma Unreferenced (Res);
 304
 305    begin
 306       if Port.H /= null then
 307          Res := close (int (Port.H.all));
 308          Unchecked_Free (Port.H);
 309       end if;
 310    end Close;
 311
 312 end GNAT.Serial_Communications;