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-2012, 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 & " (" & Integer'Image (Error) & ')';
 136    end Raise_Error;
 137
 138    ----------
 139    -- Read --
 140    ----------
 141
 142    overriding procedure Read
 143      (Port   : in out Serial_Port;
 144       Buffer : out Stream_Element_Array;
 145       Last   : out Stream_Element_Offset)
 146    is
 147       Len : constant size_t := Buffer'Length;
 148       Res : ssize_t;
 149
 150    begin
 151       if Port.H = null then
 152          Raise_Error ("read: port not opened", 0);
 153       end if;
 154
 155       Res := read (Integer (Port.H.all), Buffer'Address, Len);
 156
 157       if Res = -1 then
 158          Raise_Error ("read failed");
 159       end if;
 160
 161       Last := Last_Index (Buffer'First, size_t (Res));
 162    end Read;
 163
 164    ---------
 165    -- Set --
 166    ---------
 167
 168    procedure Set
 169      (Port      : Serial_Port;
 170       Rate      : Data_Rate        := B9600;
 171       Bits      : Data_Bits        := CS8;
 172       Stop_Bits : Stop_Bits_Number := One;
 173       Parity    : Parity_Check     := None;
 174       Block     : Boolean          := True;
 175       Local     : Boolean          := True;
 176       Flow      : Flow_Control     := None;
 177       Timeout   : Duration         := 10.0)
 178    is
 179       use OSC;
 180
 181       type termios is record
 182          c_iflag  : unsigned;
 183          c_oflag  : unsigned;
 184          c_cflag  : unsigned;
 185          c_lflag  : unsigned;
 186          c_line   : unsigned_char;
 187          c_cc     : Interfaces.C.char_array (0 .. 31);
 188          c_ispeed : unsigned;
 189          c_ospeed : unsigned;
 190       end record;
 191       pragma Convention (C, termios);
 192
 193       function tcgetattr (fd : int; termios_p : Address) return int;
 194       pragma Import (C, tcgetattr, "tcgetattr");
 195
 196       function tcsetattr
 197         (fd : int; action : int; termios_p : Address) return int;
 198       pragma Import (C, tcsetattr, "tcsetattr");
 199
 200       function tcflush (fd : int; queue_selector : int) return int;
 201       pragma Import (C, tcflush, "tcflush");
 202
 203       Current : termios;
 204
 205       Res : int;
 206       pragma Warnings (Off, Res);
 207       --  Warnings off, since we don't always test the result
 208
 209    begin
 210       if Port.H = null then
 211          Raise_Error ("set: port not opened", 0);
 212       end if;
 213
 214       --  Get current port settings
 215
 216       Res := tcgetattr (int (Port.H.all), Current'Address);
 217
 218       --  Change settings now
 219
 220       Current.c_cflag      := C_Data_Rate (Rate)
 221                                 or C_Bits (Bits)
 222                                 or C_Stop_Bits (Stop_Bits)
 223                                 or C_Parity (Parity)
 224                                 or CREAD;
 225       Current.c_iflag      := 0;
 226       Current.c_lflag      := 0;
 227       Current.c_oflag      := 0;
 228
 229       if Local then
 230          Current.c_cflag := Current.c_cflag or CLOCAL;
 231       end if;
 232
 233       case Flow is
 234          when None =>
 235             null;
 236          when RTS_CTS =>
 237             Current.c_cflag := Current.c_cflag or CRTSCTS;
 238          when Xon_Xoff =>
 239             Current.c_iflag := Current.c_iflag or IXON;
 240       end case;
 241
 242       Current.c_ispeed     := Data_Rate_Value (Rate);
 243       Current.c_ospeed     := Data_Rate_Value (Rate);
 244       Current.c_cc (VMIN)  := char'Val (0);
 245       Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10));
 246
 247       --  Set port settings
 248
 249       Res := tcflush (int (Port.H.all), TCIFLUSH);
 250       Res := tcsetattr (int (Port.H.all), TCSANOW, Current'Address);
 251
 252       --  Block
 253
 254       Res := fcntl (int (Port.H.all), F_SETFL, (if Block then 0 else FNDELAY));
 255
 256       if Res = -1 then
 257          Raise_Error ("set: fcntl failed");
 258       end if;
 259    end Set;
 260
 261    -----------
 262    -- Write --
 263    -----------
 264
 265    overriding procedure Write
 266      (Port   : in out Serial_Port;
 267       Buffer : Stream_Element_Array)
 268    is
 269       Len : constant size_t := Buffer'Length;
 270       Res : ssize_t;
 271
 272    begin
 273       if Port.H = null then
 274          Raise_Error ("write: port not opened", 0);
 275       end if;
 276
 277       Res := write (int (Port.H.all), Buffer'Address, Len);
 278
 279       if Res = -1 then
 280          Raise_Error ("write failed");
 281       end if;
 282
 283       pragma Assert (size_t (Res) = Len);
 284    end Write;
 285
 286    -----------
 287    -- Close --
 288    -----------
 289
 290    procedure Close (Port : in out Serial_Port) is
 291       procedure Unchecked_Free is
 292         new Unchecked_Deallocation (Port_Data, Port_Data_Access);
 293
 294       Res : int;
 295       pragma Unreferenced (Res);
 296
 297    begin
 298       if Port.H /= null then
 299          Res := close (int (Port.H.all));
 300          Unchecked_Free (Port.H);
 301       end if;
 302    end Close;
 303
 304 end GNAT.Serial_Communications;