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