[Ada] GNAT.Socket fixes and code reorg

Arnaud Charlet charlet@adacore.com
Mon Nov 30 10:00:00 GMT 2009


First, we fix setting of Last OUT formal in GNAT.Serial_Communication.Read
This routine was setting Last to Buffer'First - 1 when no data
had been read. If Buffer'First = Stream_Element_Offset'First then
then a constraint error was raised. To avoid this problem Last is
now set to Stream_Element_Offset'Last in this case.

This change also fixes an inaccurate comment in the documentation
for GNAT.Serial_Communication.Read and reorganizes
GNAT.Sockets.Thin.Socket_Error_Message to take advantage of
System.CRTL.strerror (shared with s-fileio).

Tested on x86_64-pc-linux-gnu, committed on trunk

2009-11-30  Thomas Quinot  <quinot@adacore.com>

	* s-commun.adb, s-commun.ads: New internal support unit,
	allowing code sharing between GNAT.Sockets and
	GNAT.Serial_Communication.
	* g-sercom.ads, g-sercom-mingw.adb, g-sercom-linux.adb,
	g-socket.adb (GNAT.Sockets.Last_Index): Move to System.Communication.
	(GNAT.Serial_Communication.Read): Handle correctly the case where no
	data was read, and Buffer'First = Stream_Element_Offset'First.
	* Makefile.rtl: Add entry for s-commun
	* g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb,
	g-socthi-vxworks.ads, g-stseme.adb, g-socthi-mingw.ads,
	g-socthi.adb, g-socthi.ads (GNAT.Sockets.Thin.Socket_Error_Message):
	Reimplement in terms of System.CRTL.strerror.

-------------- next part --------------
Index: g-sercom.ads
===================================================================
--- g-sercom.ads	(revision 154755)
+++ g-sercom.ads	(working copy)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---                    Copyright (C) 2007-2008, AdaCore                      --
+--                    Copyright (C) 2007-2009, AdaCore                      --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -91,7 +91,9 @@ package GNAT.Serial_Communications is
       Buffer : out Ada.Streams.Stream_Element_Array;
       Last   : out Ada.Streams.Stream_Element_Offset);
    --  Read a set of bytes, put result into Buffer and set Last accordingly.
-   --  Last is set to 0 if no byte has been read.
+   --  Last is set to Buffer'First - 1 if no byte has been read, unless
+   --  Buffer'First = Stream_Element_Offset'First, in which case Last is
+   --  set to Stream_Element_Offset'Last instead.
 
    overriding procedure Write
      (Port   : in out Serial_Port;
Index: g-sercom-mingw.adb
===================================================================
--- g-sercom-mingw.adb	(revision 154755)
+++ g-sercom-mingw.adb	(working copy)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                    Copyright (C) 2007-2008, AdaCore                      --
+--                    Copyright (C) 2007-2009, AdaCore                      --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -35,7 +35,11 @@
 
 with Ada.Unchecked_Deallocation; use Ada;
 with Ada.Streams;                use Ada.Streams;
-with System.Win32.Ext;           use System, System.Win32, System.Win32.Ext;
+
+with System;               use System;
+with System.Communication; use System.Communication;
+with System.Win32;         use System.Win32;
+with System.Win32.Ext;     use System.Win32.Ext;
 
 package body GNAT.Serial_Communications is
 
@@ -158,7 +162,7 @@ package body GNAT.Serial_Communications 
          Raise_Error ("read error");
       end if;
 
-      Last := Buffer'First - 1 + Stream_Element_Offset (Read_Last);
+      Last := Last_Index (Buffer'First, C.int (Read_Last));
    end Read;
 
    ---------
Index: g-sercom-linux.adb
===================================================================
--- g-sercom-linux.adb	(revision 154755)
+++ g-sercom-linux.adb	(working copy)
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---                    Copyright (C) 2007-2008, AdaCore                      --
+--                    Copyright (C) 2007-2009, AdaCore                      --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -37,7 +37,9 @@ with Ada.Streams;                use Ada
 with Ada;                        use Ada;
 with Ada.Unchecked_Deallocation;
 
-with System.CRTL; use System, System.CRTL;
+with System;               use System;
+with System.Communication; use System.Communication;
+with System.CRTL;          use System.CRTL;
 
 with GNAT.OS_Lib; use GNAT.OS_Lib;
 
@@ -167,11 +169,10 @@ package body GNAT.Serial_Communications 
       Res := read (Integer (Port.H.all), Buffer'Address, Len);
 
       if Res = -1 then
-         Last := 0;
          Raise_Error ("read failed");
-      else
-         Last := Buffer'First + Stream_Element_Offset (Res) - 1;
       end if;
+
+      Last := Last_Index (Buffer'First, C.int (Res));
    end Read;
 
    ---------
Index: s-commun.adb
===================================================================
--- s-commun.adb	(revision 0)
+++ s-commun.adb	(revision 0)
@@ -0,0 +1,53 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                 S Y S T E M . C O M M U N I C A T I O N                  --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                     Copyright (C) 2001-2009, AdaCore                     --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+package body System.Communication is
+
+   subtype SEO is Ada.Streams.Stream_Element_Offset;
+
+   ----------------
+   -- Last_Index --
+   ----------------
+
+   function Last_Index
+     (First : Ada.Streams.Stream_Element_Offset;
+      Count : C.int) return Ada.Streams.Stream_Element_Offset
+   is
+      use type Ada.Streams.Stream_Element_Offset;
+   begin
+      if First = SEO'First and then Count = 0 then
+         return SEO'Last;
+      else
+         return First + SEO (Count - 1);
+      end if;
+   end Last_Index;
+
+end System.Communication;
Index: s-commun.ads
===================================================================
--- s-commun.ads	(revision 0)
+++ s-commun.ads	(revision 0)
@@ -0,0 +1,51 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                 S Y S T E M . C O M M U N I C A T I O N                  --
+--                                                                          --
+--                                 S p e c                                  --
+--                                                                          --
+--                     Copyright (C) 2001-2009, AdaCore                     --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  Common support unit for GNAT.Sockets and GNAT.Serial_Communication
+
+with Ada.Streams;
+with Interfaces.C;
+
+package System.Communication is
+
+   package C renames Interfaces.C;
+
+   use type C.int;
+
+   function Last_Index
+     (First : Ada.Streams.Stream_Element_Offset;
+      Count : C.int) return Ada.Streams.Stream_Element_Offset;
+   --  Compute the Last OUT parameter for the various Read / Receive
+   --  subprograms: returns First + Count - 1, except for the case
+   --  where First = Stream_Element_Offset'First and Res = 0, in which
+   --  case Stream_Element_Offset'Last is returned instead.
+
+end System.Communication;
Index: g-socket.adb
===================================================================
--- g-socket.adb	(revision 154755)
+++ g-socket.adb	(working copy)
@@ -46,7 +46,8 @@ with GNAT.Sockets.Linker_Options;
 pragma Warnings (Off, GNAT.Sockets.Linker_Options);
 --  Need to include pragma Linker_Options which is platform dependent
 
-with System; use System;
+with System;               use System;
+with System.Communication; use System.Communication;
 
 package body GNAT.Sockets is
 
@@ -249,14 +250,6 @@ package body GNAT.Sockets is
    function Err_Code_Image (E : Integer) return String;
    --  Return the value of E surrounded with brackets
 
-   function Last_Index
-     (First : Stream_Element_Offset;
-      Count : C.int) return Stream_Element_Offset;
-   --  Compute the Last OUT parameter for the various Receive_Socket
-   --  subprograms: returns First + Count - 1, except for the case
-   --  where First = Stream_Element_Offset'First and Res = 0, in which
-   --  case Stream_Element_Offset'Last is returned instead.
-
    procedure Initialize (X : in out Sockets_Library_Controller);
    procedure Finalize   (X : in out Sockets_Library_Controller);
 
@@ -1416,22 +1409,6 @@ package body GNAT.Sockets is
         and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0;
    end Is_Set;
 
-   ----------------
-   -- Last_Index --
-   ----------------
-
-   function Last_Index
-     (First : Stream_Element_Offset;
-      Count : C.int) return Stream_Element_Offset
-   is
-   begin
-      if First = Stream_Element_Offset'First and then Count = 0 then
-         return Stream_Element_Offset'Last;
-      else
-         return First + Stream_Element_Offset (Count - 1);
-      end if;
-   end Last_Index;
-
    -------------------
    -- Listen_Socket --
    -------------------
Index: Makefile.rtl
===================================================================
--- Makefile.rtl	(revision 154755)
+++ Makefile.rtl	(working copy)
@@ -421,6 +421,7 @@ GNATRTL_NONTASKING_OBJS= \
   s-caun32$(objext) \
   s-caun64$(objext) \
   s-chepoo$(objext) \
+  s-commun$(objext) \
   s-conca2$(objext) \
   s-conca3$(objext) \
   s-conca4$(objext) \
Index: g-socthi-vms.adb
===================================================================
--- g-socthi-vms.adb	(revision 154755)
+++ g-socthi-vms.adb	(working copy)
@@ -473,19 +473,6 @@ package body GNAT.Sockets.Thin is
 
    function Socket_Error_Message
      (Errno : Integer) return C.Strings.chars_ptr
-   is
-      use type Interfaces.C.Strings.chars_ptr;
-
-      C_Msg : C.Strings.chars_ptr;
-
-   begin
-      C_Msg := C_Strerror (C.int (Errno));
-
-      if C_Msg = C.Strings.Null_Ptr then
-         return Unknown_System_Error;
-      else
-         return C_Msg;
-      end if;
-   end Socket_Error_Message;
+   is separate;
 
 end GNAT.Sockets.Thin;
Index: g-socthi-vms.ads
===================================================================
--- g-socthi-vms.ads	(revision 154755)
+++ g-socthi-vms.ads	(working copy)
@@ -187,9 +187,6 @@ package GNAT.Sockets.Thin is
       Typ      : C.int;
       Protocol : C.int) return C.int;
 
-   function C_Strerror
-     (Errnum : C.int) return C.Strings.chars_ptr;
-
    function C_System
      (Command : System.Address) return C.int;
 
@@ -255,7 +252,6 @@ private
    pragma Import (C, C_Select,        "DECC$SELECT");
    pragma Import (C, C_Setsockopt,    "DECC$SETSOCKOPT");
    pragma Import (C, C_Shutdown,      "DECC$SHUTDOWN");
-   pragma Import (C, C_Strerror,      "DECC$STRERROR");
    pragma Import (C, C_System,        "DECC$SYSTEM");
 
    pragma Import (C, Nonreentrant_Gethostbyname, "DECC$GETHOSTBYNAME");
Index: g-socthi-vxworks.adb
===================================================================
--- g-socthi-vxworks.adb	(revision 154755)
+++ g-socthi-vxworks.adb	(working copy)
@@ -489,20 +489,6 @@ package body GNAT.Sockets.Thin is
 
    function Socket_Error_Message
      (Errno : Integer) return C.Strings.chars_ptr
-   is
-      use type Interfaces.C.Strings.chars_ptr;
-
-      C_Msg : C.Strings.chars_ptr;
-
-   begin
-      C_Msg := C_Strerror (C.int (Errno));
-
-      if C_Msg = C.Strings.Null_Ptr then
-         return Unknown_System_Error;
-
-      else
-         return C_Msg;
-      end if;
-   end Socket_Error_Message;
+   is separate;
 
 end GNAT.Sockets.Thin;
Index: g-socthi-vxworks.ads
===================================================================
--- g-socthi-vxworks.ads	(revision 154755)
+++ g-socthi-vxworks.ads	(working copy)
@@ -185,9 +185,6 @@ package GNAT.Sockets.Thin is
       Typ      : C.int;
       Protocol : C.int) return C.int;
 
-   function C_Strerror
-     (Errnum : C.int) return C.Strings.chars_ptr;
-
    function C_System
      (Command : System.Address) return C.int;
 
@@ -232,6 +229,5 @@ private
    pragma Import (C, C_Select, "select");
    pragma Import (C, C_Setsockopt, "setsockopt");
    pragma Import (C, C_Shutdown, "shutdown");
-   pragma Import (C, C_Strerror, "strerror");
    pragma Import (C, C_System, "system");
 end GNAT.Sockets.Thin;
Index: g-stseme.adb
===================================================================
--- g-stseme.adb	(revision 0)
+++ g-stseme.adb	(revision 0)
@@ -0,0 +1,64 @@
+------------------------------------------------------------------------------
+--                                                                          --
+--                         GNAT COMPILER COMPONENTS                         --
+--                                                                          --
+--                  GNAT.SOCKETS.THIN.SOCKET_ERROR_MESSAGE                  --
+--                                                                          --
+--                                 B o d y                                  --
+--                                                                          --
+--                     Copyright (C) 2007-2009, AdaCore                     --
+--                                                                          --
+-- GNAT is free software;  you can  redistribute it  and/or modify it under --
+-- terms of the  GNU General Public License as published  by the Free Soft- --
+-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
+-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
+-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
+-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
+--                                                                          --
+-- As a special exception under Section 7 of GPL version 3, you are granted --
+-- additional permissions described in the GCC Runtime Library Exception,   --
+-- version 3.1, as published by the Free Software Foundation.               --
+--                                                                          --
+-- You should have received a copy of the GNU General Public License and    --
+-- a copy of the GCC Runtime Library Exception along with this program;     --
+-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
+-- <http://www.gnu.org/licenses/>.                                          --
+--                                                                          --
+-- GNAT was originally developed  by the GNAT team at  New York University. --
+-- Extensive contributions were provided by Ada Core Technologies Inc.      --
+--                                                                          --
+------------------------------------------------------------------------------
+
+--  This is the default implementation of this unit, using the standard C
+--  library's strerror(3) function. It is used on all platforms except Windows,
+--  since on that platform socket errno values are distinct from the system
+--  ones: there is a specific variant of this function in g-socthi-mingw.adb.
+
+with Ada.Unchecked_Conversion;
+with System.CRTL;
+
+separate (GNAT.Sockets.Thin)
+function Socket_Error_Message
+  (Errno : Integer) return C.Strings.chars_ptr
+is
+   use type Interfaces.C.Strings.chars_ptr;
+
+   pragma Warnings (Off);
+   function To_Chars_Ptr is
+     new Ada.Unchecked_Conversion
+       (System.Address, Interfaces.C.Strings.chars_ptr);
+   --  On VMS, the compiler warns because System.Address is 64 bits, but
+   --  chars_ptr is 32 bits. It should be safe, though, because strerror
+   --  will return a 32-bit pointer.
+   pragma Warnings (On);
+
+   C_Msg : C.Strings.chars_ptr;
+
+begin
+   C_Msg := To_Chars_Ptr (System.CRTL.strerror (Errno));
+   if C_Msg = C.Strings.Null_Ptr then
+      return Unknown_System_Error;
+   else
+      return C_Msg;
+   end if;
+end Socket_Error_Message;
Index: g-socthi-mingw.ads
===================================================================
--- g-socthi-mingw.ads	(revision 154755)
+++ g-socthi-mingw.ads	(working copy)
@@ -184,9 +184,6 @@ package GNAT.Sockets.Thin is
       Typ      : C.int;
       Protocol : C.int) return C.int;
 
-   function C_Strerror
-     (Errnum : C.int) return C.Strings.chars_ptr;
-
    function C_System
      (Command : System.Address) return C.int;
 
@@ -241,7 +238,6 @@ private
    pragma Import (Stdcall, C_Setsockopt, "setsockopt");
    pragma Import (Stdcall, C_Shutdown, "shutdown");
    pragma Import (Stdcall, C_Socket, "socket");
-   pragma Import (C, C_Strerror, "strerror");
    pragma Import (C, C_System, "_system");
    pragma Import (Stdcall, Socket_Errno, "WSAGetLastError");
    pragma Import (Stdcall, Set_Socket_Errno, "WSASetLastError");
Index: g-socthi.adb
===================================================================
--- g-socthi.adb	(revision 154755)
+++ g-socthi.adb	(working copy)
@@ -494,19 +494,6 @@ package body GNAT.Sockets.Thin is
 
    function Socket_Error_Message
      (Errno : Integer) return C.Strings.chars_ptr
-   is
-      use type Interfaces.C.Strings.chars_ptr;
-
-      C_Msg : C.Strings.chars_ptr;
-
-   begin
-      C_Msg := C_Strerror (C.int (Errno));
-
-      if C_Msg = C.Strings.Null_Ptr then
-         return Unknown_System_Error;
-      else
-         return C_Msg;
-      end if;
-   end Socket_Error_Message;
+   is separate;
 
 end GNAT.Sockets.Thin;
Index: g-socthi.ads
===================================================================
--- g-socthi.ads	(revision 154755)
+++ g-socthi.ads	(working copy)
@@ -186,9 +186,6 @@ package GNAT.Sockets.Thin is
       Typ      : C.int;
       Protocol : C.int) return C.int;
 
-   function C_Strerror
-     (Errnum : C.int) return C.Strings.chars_ptr;
-
    function C_System
      (Command : System.Address) return C.int;
 
@@ -257,7 +254,6 @@ private
    pragma Import (C, C_Select, "select");
    pragma Import (C, C_Setsockopt, "setsockopt");
    pragma Import (C, C_Shutdown, "shutdown");
-   pragma Import (C, C_Strerror, "strerror");
    pragma Import (C, C_System, "system");
 
    pragma Import (C, Nonreentrant_Gethostbyname, "gethostbyname");


More information about the Gcc-patches mailing list