gcc/ada/g-sercom-mingw.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-2016, 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 Windows implementation of this package
  33
  34 with Ada.Streams;                use Ada.Streams;
  35 with Ada.Unchecked_Deallocation; use Ada;
  36
  37 with System;               use System;
  38 with System.Communication; use System.Communication;
  39 with System.CRTL;          use System.CRTL;
  40 with System.OS_Constants;
  41 with System.Win32;         use System.Win32;
  42 with System.Win32.Ext;     use System.Win32.Ext;
  43
  44 with GNAT.OS_Lib;
  45
  46 package body GNAT.Serial_Communications is
  47
  48    package OSC renames System.OS_Constants;
  49
  50    --  Common types
  51
  52    type Port_Data is new HANDLE;
  53
  54    C_Bits      : constant array (Data_Bits) of Interfaces.C.unsigned := (8, 7);
  55    C_Parity    : constant array (Parity_Check) of Interfaces.C.unsigned :=
  56                    (None => NOPARITY, Odd => ODDPARITY, Even => EVENPARITY);
  57    C_Stop_Bits : constant array (Stop_Bits_Number) of Interfaces.C.unsigned :=
  58                    (One => ONESTOPBIT, Two => TWOSTOPBITS);
  59
  60    -----------
  61    -- Files --
  62    -----------
  63
  64    procedure Raise_Error (Message : String; Error : DWORD := GetLastError);
  65    pragma No_Return (Raise_Error);
  66
  67    -----------
  68    -- Close --
  69    -----------
  70
  71    procedure Close (Port : in out Serial_Port) is
  72       procedure Unchecked_Free is
  73         new Unchecked_Deallocation (Port_Data, Port_Data_Access);
  74
  75       Success : BOOL;
  76
  77    begin
  78       if Port.H /= null then
  79          Success := CloseHandle (HANDLE (Port.H.all));
  80          Unchecked_Free (Port.H);
  81
  82          if Success = Win32.FALSE then
  83             Raise_Error ("error closing the port");
  84          end if;
  85       end if;
  86    end Close;
  87
  88    ----------
  89    -- Name --
  90    ----------
  91
  92    function Name (Number : Positive) return Port_Name is
  93       N_Img : constant String := Positive'Image (Number);
  94    begin
  95       if Number > 9 then
  96          return
  97            Port_Name ("\\.\COM" & N_Img (N_Img'First + 1 .. N_Img'Last));
  98       else
  99          return
 100            Port_Name ("COM" & N_Img (N_Img'First + 1 .. N_Img'Last) & ':');
 101       end if;
 102    end Name;
 103
 104    ----------
 105    -- Open --
 106    ----------
 107
 108    procedure Open
 109      (Port : out Serial_Port;
 110       Name : Port_Name)
 111    is
 112       C_Name  : constant String := String (Name) & ASCII.NUL;
 113       Success : BOOL;
 114       pragma Unreferenced (Success);
 115
 116    begin
 117       if Port.H = null then
 118          Port.H := new Port_Data;
 119       else
 120          Success := CloseHandle (HANDLE (Port.H.all));
 121       end if;
 122
 123       Port.H.all := CreateFileA
 124         (lpFileName            => C_Name (C_Name'First)'Address,
 125          dwDesiredAccess       => GENERIC_READ or GENERIC_WRITE,
 126          dwShareMode           => 0,
 127          lpSecurityAttributes  => null,
 128          dwCreationDisposition => OPEN_EXISTING,
 129          dwFlagsAndAttributes  => 0,
 130          hTemplateFile         => 0);
 131
 132       if Port.H.all = Port_Data (INVALID_HANDLE_VALUE) then
 133          Raise_Error ("cannot open com port");
 134       end if;
 135    end Open;
 136
 137    -----------------
 138    -- Raise_Error --
 139    -----------------
 140
 141    procedure Raise_Error (Message : String; Error : DWORD := GetLastError) is
 142    begin
 143       raise Serial_Error with Message
 144         & (if Error /= 0
 145            then " (" & GNAT.OS_Lib.Errno_Message (Err => Integer (Error)) & ')'
 146            else "");
 147    end Raise_Error;
 148
 149    ----------
 150    -- Read --
 151    ----------
 152
 153    overriding procedure Read
 154      (Port   : in out Serial_Port;
 155       Buffer : out Stream_Element_Array;
 156       Last   : out Stream_Element_Offset)
 157    is
 158       Success   : BOOL;
 159       Read_Last : aliased DWORD;
 160
 161    begin
 162       if Port.H = null then
 163          Raise_Error ("read: port not opened", 0);
 164       end if;
 165
 166       Success :=
 167         ReadFile
 168           (hFile                => HANDLE (Port.H.all),
 169            lpBuffer             => Buffer (Buffer'First)'Address,
 170            nNumberOfBytesToRead => DWORD (Buffer'Length),
 171            lpNumberOfBytesRead  => Read_Last'Access,
 172            lpOverlapped         => null);
 173
 174       if Success = Win32.FALSE then
 175          Raise_Error ("read error");
 176       end if;
 177
 178       Last := Last_Index (Buffer'First, size_t (Read_Last));
 179    end Read;
 180
 181    ---------
 182    -- Set --
 183    ---------
 184
 185    procedure Set
 186      (Port      : Serial_Port;
 187       Rate      : Data_Rate        := B9600;
 188       Bits      : Data_Bits        := CS8;
 189       Stop_Bits : Stop_Bits_Number := One;
 190       Parity    : Parity_Check     := None;
 191       Block     : Boolean          := True;
 192       Local     : Boolean          := True;
 193       Flow      : Flow_Control     := None;
 194       Timeout   : Duration         := 10.0)
 195    is
 196       pragma Unreferenced (Local);
 197
 198       Success      : BOOL;
 199       Com_Time_Out : aliased COMMTIMEOUTS;
 200       Com_Settings : aliased DCB;
 201
 202    begin
 203       if Port.H = null then
 204          Raise_Error ("set: port not opened", 0);
 205       end if;
 206
 207       Success := GetCommState (HANDLE (Port.H.all), Com_Settings'Access);
 208
 209       if Success = Win32.FALSE then
 210          Success := CloseHandle (HANDLE (Port.H.all));
 211          Port.H.all := 0;
 212          Raise_Error ("set: cannot get comm state");
 213       end if;
 214
 215       Com_Settings.BaudRate        := DWORD (Data_Rate_Value (Rate));
 216       Com_Settings.fParity         := 1;
 217       Com_Settings.fBinary         := Bits1 (System.Win32.TRUE);
 218       Com_Settings.fOutxDsrFlow    := 0;
 219       Com_Settings.fDsrSensitivity := 0;
 220       Com_Settings.fDtrControl     := OSC.DTR_CONTROL_ENABLE;
 221       Com_Settings.fInX            := 0;
 222       Com_Settings.fRtsControl     := OSC.RTS_CONTROL_ENABLE;
 223
 224       case Flow is
 225          when None =>
 226             Com_Settings.fOutX        := 0;
 227             Com_Settings.fOutxCtsFlow := 0;
 228
 229          when RTS_CTS =>
 230             Com_Settings.fOutX        := 0;
 231             Com_Settings.fOutxCtsFlow := 1;
 232
 233          when Xon_Xoff =>
 234             Com_Settings.fOutX        := 1;
 235             Com_Settings.fOutxCtsFlow := 0;
 236       end case;
 237
 238       Com_Settings.fAbortOnError := 0;
 239       Com_Settings.ByteSize      := BYTE (C_Bits (Bits));
 240       Com_Settings.Parity        := BYTE (C_Parity (Parity));
 241       Com_Settings.StopBits      := BYTE (C_Stop_Bits (Stop_Bits));
 242
 243       Success := SetCommState (HANDLE (Port.H.all), Com_Settings'Access);
 244
 245       if Success = Win32.FALSE then
 246          Success := CloseHandle (HANDLE (Port.H.all));
 247          Port.H.all := 0;
 248          Raise_Error ("cannot set comm state");
 249       end if;
 250
 251       --  Set the timeout status, to honor our spec with respect to read
 252       --  timeouts. Always disconnect write timeouts.
 253
 254       --  Blocking reads - no timeout at all
 255
 256       if Block then
 257          Com_Time_Out := (others => 0);
 258
 259       --  Non-blocking reads and null timeout - immediate return with what we
 260       --  have - set ReadIntervalTimeout to MAXDWORD.
 261
 262       elsif Timeout = 0.0 then
 263          Com_Time_Out :=
 264            (ReadIntervalTimeout => DWORD'Last,
 265             others              => 0);
 266
 267       --  Non-blocking reads with timeout - set total read timeout accordingly
 268
 269       else
 270          Com_Time_Out :=
 271            (ReadTotalTimeoutConstant => DWORD (1000 * Timeout),
 272             others                   => 0);
 273       end if;
 274
 275       Success :=
 276         SetCommTimeouts
 277           (hFile          => HANDLE (Port.H.all),
 278            lpCommTimeouts => Com_Time_Out'Access);
 279
 280       if Success = Win32.FALSE then
 281          Raise_Error ("cannot set the timeout");
 282       end if;
 283    end Set;
 284
 285    -----------
 286    -- Write --
 287    -----------
 288
 289    overriding procedure Write
 290      (Port   : in out Serial_Port;
 291       Buffer : Stream_Element_Array)
 292    is
 293       Success   : BOOL;
 294       Temp_Last : aliased DWORD;
 295
 296    begin
 297       if Port.H = null then
 298          Raise_Error ("write: port not opened", 0);
 299       end if;
 300
 301       Success :=
 302         WriteFile
 303           (hFile                  => HANDLE (Port.H.all),
 304            lpBuffer               => Buffer'Address,
 305            nNumberOfBytesToWrite  => DWORD (Buffer'Length),
 306            lpNumberOfBytesWritten => Temp_Last'Access,
 307            lpOverlapped           => null);
 308
 309       if Success = Win32.FALSE
 310         or else Stream_Element_Offset (Temp_Last) /= Buffer'Length
 311       then
 312          Raise_Error ("failed to write data");
 313       end if;
 314    end Write;
 315
 316 end GNAT.Serial_Communications;