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