Skip to content

R
riscv-gcc-1
Commit 3d3bf932 by Thomas Quinot Committed by Arnaud Charlet
Options

g-stsifd-sockets.adb: New file. 

2007-04-06  Thomas Quinot  <quinot@adacore.com>
	    Pat Rogers  <rogers@adacore.com>
	    Pascal Obry  <obry@adacore.com>

	* g-stsifd-sockets.adb: New file.

	* g-socthi.ads, g-socket.adb, g-socthi-vxworks.adb,
	g-socthi-vxworks.ads, g-socthi-mingw.ads, g-socthi-vms.ads,
	g-socthi-vms.adb: Move signalling
	fd management to a nested package, so that they can conveniently be
	moved to a subunit that is shared across Windows, VMS, and VxWorks
	(Ada implementation) or completed with imported bodies from socket.c
	(UNIX case).
	(Read_Signalling_Fd, Write_Signalling_Fd, Create_Signalling_Fds): New
	subprograms.
	(Check_Selector): Use Read_Signalling_Fd to read and discard data from
	the signalling file descriptor.
	(Abort_Selector): Use Write_Signalling_Fd to write dummy data to the
	signalling file descriptor.
	(Create_Selector): Use new C-imported subprogram Create_Signalling_Fds
	instead of creating a pair of sockets for signalling here.

	* g-socthi.adb: Ditto.
	Set the runtime process to ignore SIGPIPEs on platforms that support
	neither SO_NOSIGPIPE nor MSG_NOSIGNAL functionality.

	* g-socthi-mingw.adb: Ditto.
	(WS_Version): Use Windows 2.2.
	Use Winsock 2.2 (instead of 1.1) for the GNAT.Socket API.

	* g-soliop-mingw.ads: Link with ws2_32 for Windows 2.x support.
	Use Winsock 2.2 (instead of 1.1) for the GNAT.Socket API.

	* Makefile.in: New libgnat pair g-stsifd.adb<g-stsifd-sockets.adb.
	added GNAT byte swapping facility
	Update FreeBSD THREADSLIB from -lc_r to -lpthread, for FreeBSD 6.

	* g-bytswa.adb, g-bytswa-x86.adb, g-bytswa.ads: New files.

	* socket.c (__gnat_read_signalling_fd, __gnat_write_controlling_fd):
	New subprograms.
	(__gnat_create_signalling_fds): New subprogram.
	Set the runtime process to ignore SIGPIPEs on platforms that support
	neither SO_NOSIGPIPE nor MSG_NOSIGNAL functionality.

From-SVN: r123542
parent baa3441d
Showing with 1118 additions and 210 deletions
gcc/ada/Makefile.in
# Makefile for GNU Ada Compiler (GNAT).
# Copyright (C) 1994-2005 Free Software Foundation, Inc.
# Copyright (C) 1994-2006 Free Software Foundation, Inc.
#This file is part of GCC.
......@@ -409,6 +409,7 @@ ifeq ($(strip $(filter-out m68k% wrs vx%,$(targ))),)
g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
system.ads<system-vxworks-m68k.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
......@@ -444,7 +445,8 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),)
s-vxwork.ads<s-vxwork-ppc.ads \
g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
......@@ -501,6 +503,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(targ))),)
g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
system.ads<system-vxworks-ppc-vthread.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
......@@ -546,6 +549,7 @@ ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),)
g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
system.ads<system-vxworks-sparcv9.ads \
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
......@@ -572,9 +576,11 @@ ifeq ($(strip $(filter-out %86 wrs vxworks,$(targ))),)
s-taprop.adb<s-taprop-vxworks.adb \
s-taspri.ads<s-taspri-vxworks.ads \
s-vxwork.ads<s-vxwork-x86.ads \
g-bytswa.adb<g-bytswa-x86.adb \
g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
......@@ -627,6 +633,7 @@ ifeq ($(strip $(filter-out arm% coff wrs vx%,$(targ))),)
g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
system.ads<system-vxworks-arm.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
......@@ -656,6 +663,7 @@ ifeq ($(strip $(filter-out mips% wrs vx%,$(targ))),)
g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<g-socthi-vxworks.ads \
g-socthi.adb<g-socthi-vxworks.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
system.ads<system-vxworks-mips.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
......@@ -752,6 +760,7 @@ ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),)
s-tasinf.ads<s-tasinf-solaris.ads \
s-taspri.ads<s-taspri-solaris.ads \
s-tpopsp.adb<s-tpopsp-solaris.adb \
g-bytswa.adb<g-bytswa-x86.adb \
g-soccon.ads<g-soccon-solaris.ads \
g-soliop.ads<g-soliop-solaris.ads \
system.ads<system-solaris-x86.ads
......@@ -772,6 +781,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
a-intnam.ads<a-intnam-linux.ads \
a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<a-numaux-x86.ads \
g-bytswa.adb<g-bytswa-x86.adb \
g-soccon.ads<g-soccon-linux-x86.ads \
s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \
......@@ -828,6 +838,7 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),)
a-intnam.ads<a-intnam-freebsd.ads \
a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<a-numaux-x86.ads \
g-bytswa.adb<g-bytswa-x86.adb \
g-soccon.ads<g-soccon-freebsd.ads \
s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \
......@@ -844,7 +855,7 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),)
GNATLIB_SHARED = gnatlib-shared-dual
EH_MECHANISM=-gcc
THREADSLIB= -lc_r
THREADSLIB= -lpthread
GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(LIB_VERSION)
......@@ -1010,6 +1021,7 @@ ifeq ($(strip $(filter-out lynxos,$(osys))),)
a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<a-numaux-x86.ads \
a-intnam.ads<a-intnam-lynxos.ads \
g-bytswa.adb<g-bytswa-x86.adb \
s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \
s-osinte.adb<s-osinte-lynxos.adb \
......@@ -1142,6 +1154,7 @@ endif
g-soccon.ads<g-soccon-vms.ads \
g-socthi.ads<g-socthi-vms.ads \
g-socthi.adb<g-socthi-vms.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
i-c.ads<i-c-vms_64.ads \
i-cstrin.ads<i-cstrin-vms_64.ads \
i-cstrin.adb<i-cstrin-vms_64.adb \
......@@ -1212,8 +1225,10 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
s-osprim.adb<s-osprim-mingw.adb \
s-taprop.adb<s-taprop-mingw.adb \
s-taspri.ads<s-taspri-mingw.ads \
g-bytswa.adb<g-bytswa-x86.adb \
g-socthi.ads<g-socthi-mingw.ads \
g-socthi.adb<g-socthi-mingw.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
g-soccon.ads<g-soccon-mingw.ads \
g-soliop.ads<g-soliop-mingw.ads \
system.ads<system-mingw.ads
......
gcc/ada/g-bytswa-x86.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . B Y T E _ S W A P P I N G --
-- --
-- B o d y --
-- --
-- Copyright (C) 2006, 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 2, 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. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is a machine-specific version of this package.
-- It uses instructions available on Intel 486 processors (or later).
with Interfaces; use Interfaces;
with System.Machine_Code; use System.Machine_Code;
with Ada.Unchecked_Conversion;
package body GNAT.Byte_Swapping is
-----------------------
-- Local Subprograms --
-----------------------
function Swapped32 (Value : Unsigned_32) return Unsigned_32;
pragma Inline_Always (Swapped32);
--------------
-- Swapped2 --
--------------
function Swapped2 (Input : Item) return Item is
function As_U16 is new Ada.Unchecked_Conversion
(Source => Item, Target => Unsigned_16);
function As_Item is new Ada.Unchecked_Conversion
(Source => Unsigned_16, Target => Item);
X : Unsigned_16 := As_U16 (Input);
begin
Asm ("xchgb %b0,%h0",
Unsigned_16'Asm_Output ("=q", X),
Unsigned_16'Asm_Input ("0", X));
return As_Item (X);
end Swapped2;
--------------
-- Swapped4 --
--------------
function Swapped4 (Input : Item) return Item is
function As_U32 is new Ada.Unchecked_Conversion
(Source => Item, Target => Unsigned_32);
function As_Item is new Ada.Unchecked_Conversion
(Source => Unsigned_32, Target => Item);
X : Unsigned_32 := As_U32 (Input);
begin
Asm ("bswap %0",
Unsigned_32'Asm_Output ("=r", X),
Unsigned_32'Asm_Input ("0", X));
return As_Item (X);
end Swapped4;
--------------
-- Swapped8 --
--------------
function Swapped8 (Input : Item) return Item is
function As_U64 is new Ada.Unchecked_Conversion
(Source => Item, Target => Unsigned_64);
X : Unsigned_64 renames As_U64 (Input);
type Two_Words is array (0 .. 1) of Unsigned_32;
for Two_Words'Component_Size use Unsigned_32'Size;
function As_Item is new Ada.Unchecked_Conversion
(Source => Two_Words, Target => Item);
Result : Two_Words;
begin
Asm ("xchgl %0,%1",
Outputs =>
(Unsigned_32'Asm_Output ("=r", Result (0)),
Unsigned_32'Asm_Output ("=r", Result (1))),
Inputs =>
(Unsigned_32'Asm_Input ("0",
Swapped32 (Unsigned_32 (X and 16#0000_0000_FFFF_FFFF#))),
Unsigned_32'Asm_Input ("1",
Swapped32 (Unsigned_32 (Shift_Right (X, 32))))));
return As_Item (Result);
end Swapped8;
-----------
-- Swap2 --
-----------
procedure Swap2 (Location : in System.Address) is
X : Unsigned_16;
for X'Address use Location;
begin
Asm ("xchgb %b0,%h0",
Unsigned_16'Asm_Output ("=q", X),
Unsigned_16'Asm_Input ("0", X));
end Swap2;
-----------
-- Swap4 --
-----------
procedure Swap4 (Location : in System.Address) is
X : Unsigned_32;
for X'Address use Location;
begin
Asm ("bswap %0",
Unsigned_32'Asm_Output ("=r", X),
Unsigned_32'Asm_Input ("0", X));
end Swap4;
---------------
-- Swapped32 --
---------------
function Swapped32 (Value : Unsigned_32) return Unsigned_32 is
X : Unsigned_32 := Value;
begin
Asm ("bswap %0",
Unsigned_32'Asm_Output ("=r", X),
Unsigned_32'Asm_Input ("0", X));
return X;
end Swapped32;
-----------
-- Swap8 --
-----------
procedure Swap8 (Location : in System.Address) is
X : Unsigned_64;
for X'Address use Location;
type Two_Words is array (0 .. 1) of Unsigned_32;
for Two_Words'Component_Size use Unsigned_32'Size;
Words : Two_Words;
for Words'Address use Location;
begin
Asm ("xchgl %0,%1",
Outputs =>
(Unsigned_32'Asm_Output ("=r", Words (0)),
Unsigned_32'Asm_Output ("=r", Words (1))),
Inputs =>
(Unsigned_32'Asm_Input ("0",
Swapped32 (Unsigned_32 (X and 16#0000_0000_FFFF_FFFF#))),
Unsigned_32'Asm_Input ("1",
Swapped32 (Unsigned_32 (Shift_Right (X, 32))))));
end Swap8;
end GNAT.Byte_Swapping;
gcc/ada/g-bytswa.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . B Y T E _ S W A P P I N G --
-- --
-- B o d y --
-- --
-- Copyright (C) 2006, 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 2, 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. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This is a general implementation that does not take advantage of
-- any machine-specific instructions.
with Interfaces; use Interfaces;
with Ada.Unchecked_Conversion;
package body GNAT.Byte_Swapping is
--------------
-- Swapped2 --
--------------
function Swapped2 (Input : Item) return Item is
function As_U16 is new Ada.Unchecked_Conversion
(Source => Item, Target => Unsigned_16);
function As_Item is new Ada.Unchecked_Conversion
(Source => Unsigned_16, Target => Item);
X : Unsigned_16 renames As_U16 (Input);
begin
return As_Item ((Shift_Left (X, 8) and 16#FF00#) or
(Shift_Right (X, 8) and 16#00FF#));
end Swapped2;
--------------
-- Swapped4 --
--------------
function Swapped4 (Input : Item) return Item is
function As_U32 is new Ada.Unchecked_Conversion
(Source => Item, Target => Unsigned_32);
function As_Item is new Ada.Unchecked_Conversion
(Source => Unsigned_32, Target => Item);
X : Unsigned_32 renames As_U32 (Input);
begin
return As_Item ((Shift_Right (X, 24) and 16#0000_00FF#) or
(Shift_Right (X, 8) and 16#0000_FF00#) or
(Shift_Left (X, 8) and 16#00FF_0000#) or
(Shift_Left (X, 24) and 16#FF00_0000#));
end Swapped4;
--------------
-- Swapped8 --
--------------
function Swapped8 (Input : Item) return Item is
function As_U64 is new Ada.Unchecked_Conversion
(Source => Item, Target => Unsigned_64);
function As_Item is new Ada.Unchecked_Conversion
(Source => Unsigned_64, Target => Item);
X : Unsigned_64 renames As_U64 (Input);
Low, High : aliased Unsigned_32;
begin
Low := Unsigned_32 (X and 16#0000_0000_FFFF_FFFF#);
Swap4 (Low'Address);
High := Unsigned_32 (Shift_Right (X, 32));
Swap4 (High'Address);
return As_Item
(Shift_Left (Unsigned_64 (Low), 32) or Unsigned_64 (High));
end Swapped8;
-----------
-- Swap2 --
-----------
procedure Swap2 (Location : System.Address) is
X : Unsigned_16;
for X'Address use Location;
begin
X := (Shift_Left (X, 8) and 16#FF00#) or
(Shift_Right (X, 8) and 16#00FF#);
end Swap2;
-----------
-- Swap4 --
-----------
procedure Swap4 (Location : System.Address) is
X : Unsigned_32;
for X'Address use Location;
begin
X := (Shift_Right (X, 24) and 16#0000_00FF#) or
(Shift_Right (X, 8) and 16#0000_FF00#) or
(Shift_Left (X, 8) and 16#00FF_0000#) or
(Shift_Left (X, 24) and 16#FF00_0000#);
end Swap4;
-----------
-- Swap8 --
-----------
procedure Swap8 (Location : System.Address) is
X : Unsigned_64;
for X'Address use Location;
Low, High : aliased Unsigned_32;
begin
Low := Unsigned_32 (X and 16#0000_0000_FFFF_FFFF#);
Swap4 (Low'Address);
High := Unsigned_32 (Shift_Right (X, 32));
Swap4 (High'Address);
X := Shift_Left (Unsigned_64 (Low), 32) or Unsigned_64 (High);
end Swap8;
end GNAT.Byte_Swapping;
gcc/ada/g-bytswa.ads 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT RUN-TIME COMPONENTS --
-- --
-- G N A T . B Y T E _ S W A P P I N G --
-- --
-- S p e c --
-- --
-- Copyright (C) 2006, 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 2, 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. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Simple routines for swapping the bytes of 16-, 32-, and 64-bit objects.
-- The generic functions should be instantiated with types that
-- are of a size in bytes corresponding to the name of the generic. For
-- example, a 2-byte integer type would be compatible with Swapped2, 4-byte
-- integer with Swapped4, and so on. Failure to do so will result in a
-- warning when compiling the instantiation; this warning should be heeded.
-- Ignoring this warning can result in unexpected results.
-- An example of proper usage follows:
-- declare
-- type Short_Integer is range -32768 .. 32767;
-- for Short_Integer'Size use 16; -- for confirmation
-- X : Short_Integer := 16#7FFF#;
-- function Swapped is new Byte_Swapping.Swapped2 (Short_Integer);
-- begin
-- Put_Line (X'Img);
-- X := Swapped (X);
-- Put_Line (X'Img);
-- end;
-- Note that the generic actual types need not be scalars, but must be
-- 'definite' types. They can, for example, be constrained subtypes of
-- unconstrained array types as long as the size is correct. For instance,
-- a subtype of String with length of 4 would be compatible with the
-- Swapped4 generic:
-- declare
-- subtype String4 is String (1 .. 4);
-- function Swapped is new Byte_Swapping.Swapped4 (String4);
-- S : String4 := "ABCD";
-- begin
-- Put_Line (S);
-- S := Swapped (S);
-- Put_Line (S);
-- end;
-- Similarly, a constrained array type is also acceptable:
-- declare
-- type Mask is array (0 .. 15) of Boolean;
-- for Mask'Component_Size use Boolean'Size;
-- X : Mask := (0 .. 7 => True, others => False);
-- function Swapped is new Byte_Swapping.Swapped2 (Mask);
-- begin
-- ...
-- X := Swapped (X);
-- ...
-- end;
-- A properly-sized record type will also be acceptable, and so forth.
-- However, as described, a size mismatch must be avoided. In the following
-- we instantiate one of the generics with a type that is too large. The
-- result of the function call is undefined, such that assignment to an
-- object can result in garbage values.
-- Wrong: declare
-- subtype String16 is String (1 .. 16);
-- function Swapped is new Byte_Swapping.Swapped8 (String16);
-- -- Instantiation generates a compiler warning about
-- -- mismatched sizes
-- S : String16;
-- begin
-- S := "ABCDEFGHDEADBEEF";
--
-- Put_Line (S);
--
-- -- the following assignment results in garbage in S after the
-- -- first 8 bytes
--
-- S := Swapped (S);
--
-- Put_Line (S);
-- end Wrong;
-- When the size of the type is larger than 8 bytes, the use of the
-- non-generic procedures is an alternative because no function result is
-- involved; manipulation of the object is direct.
-- The procedures are passed the address of an object to manipulate. They will
-- swap the first N bytes of that object corresponding to the name of the
-- procedure. For example:
-- declare
-- S2 : String := "AB";
-- for S2'Alignment use 2;
-- S4 : String := "ABCD";
-- for S4'Alignment use 4;
-- S8 : String := "ABCDEFGH";
-- for S8'Alignment use 8;
-- begin
-- Swap2 (S2'Address);
-- Put_Line (S2);
-- Swap4 (S4'Address);
-- Put_Line (S4);
-- Swap8 (S8'Address);
-- Put_Line (S8);
-- end;
-- If an object of a type larger than N is passed, the remaining
-- bytes of the object are undisturbed. For example:
-- declare
-- subtype String16 is String (1 .. 16);
-- S : String16;
-- for S'Alignment use 8;
-- begin
-- S := "ABCDEFGHDEADBEEF";
-- Put_Line (S);
-- Swap8 (S'Address);
-- Put_Line (S);
-- end;
with System;
package GNAT.Byte_Swapping is
pragma Pure;
-- NB: all the routines in this package treat the application objects as
-- unsigned (modular) types of a size in bytes corresponding to the routine
-- name. For example, the generic function Swapped2 manipulates the object
-- passed to the formal parameter Input as a value of an unsigned type that
-- is 2 bytes long. Therefore clients are responsible for the compatibility
-- of application types manipulated by these routines and these modular
-- types, in terms of both size and alignment. This requirement applies to
-- the generic actual type passed to the generic formal type Item in the
-- generic functions, as well as to the type of the object implicitly
-- designated by the address passed to the non-generic procedures. Use of
-- incompatible types can result in implementation- defined effects.
generic
type Item is limited private;
function Swapped2 (Input : Item) return Item;
-- Return the 2-byte value of Input with the bytes swapped
generic
type Item is limited private;
function Swapped4 (Input : Item) return Item;
-- Return the 4-byte value of Input with the bytes swapped
generic
type Item is limited private;
function Swapped8 (Input : Item) return Item;
-- Return the 8-byte value of Input with the bytes swapped
procedure Swap2 (Location : System.Address);
-- Swap the first 2 bytes of the object starting at the address specified
-- by Location.
procedure Swap4 (Location : System.Address);
-- Swap the first 4 bytes of the object starting at the address specified
-- by Location.
procedure Swap8 (Location : System.Address);
-- Swap the first 8 bytes of the object starting at the address specified
-- by Location.
pragma Inline (Swap2, Swap4, Swap8, Swapped2, Swapped4, Swapped8);
end GNAT.Byte_Swapping;
gcc/ada/g-socket.adb
......@@ -236,14 +236,13 @@ package body GNAT.Sockets is
--------------------
procedure Abort_Selector (Selector : Selector_Type) is
Buf : aliased Character := ASCII.NUL;
Res : C.int;
begin
-- Send an empty array to unblock C select system call
-- Send one byte to unblock select system call
Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket));
Res := C_Send (C.int (Selector.W_Sig_Socket), Buf'Address, 1,
Constants.MSG_Forced_Flags);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
......@@ -454,16 +453,11 @@ package body GNAT.Sockets is
if Is_Set (RSet, RSig) then
Clear (RSet, RSig);
declare
Buf : Character;
begin
Res := C_Recv (C.int (RSig), Buf'Address, 1, 0);
Res := Signalling_Fds.Read (C.int (RSig));
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
end;
Status := Aborted;
......@@ -674,105 +668,23 @@ package body GNAT.Sockets is
---------------------
procedure Create_Selector (Selector : out Selector_Type) is
S0 : C.int;
S1 : C.int;
S2 : C.int;
Two_Fds : aliased Fd_Pair;
Res : C.int;
Sin : aliased Sockaddr_In;
Len : aliased C.int := Sin'Size / 8;
Err : Integer;
begin
-- We open two signalling sockets. One of them is used to send data to
-- the other, which is included in a C_Select socket set. The
-- communication is used to force the call to C_Select to complete, and
-- We open two signalling file descriptors. One of them is used to send
-- data to the other, which is included in a C_Select socket set. The
-- communication is used to force a call to C_Select to complete, and
-- the waiting task to resume its execution.
-- Create a listening socket
S0 := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);
if S0 = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
-- Bind the socket to any unused port on localhost
Sin.Sin_Addr.S_B1 := 127;
Sin.Sin_Addr.S_B2 := 0;
Sin.Sin_Addr.S_B3 := 0;
Sin.Sin_Addr.S_B4 := 1;
Sin.Sin_Port := 0;
Res := C_Bind (S0, Sin'Address, Len);
if Res = Failure then
Err := Socket_Errno;
Res := C_Close (S0);
Raise_Socket_Error (Err);
end if;
-- Get the port used by the socket
Res := C_Getsockname (S0, Sin'Address, Len'Access);
if Res = Failure then
Err := Socket_Errno;
Res := C_Close (S0);
Raise_Socket_Error (Err);
end if;
-- Set backlog to 1 to guarantee that exactly one call to connect(2)
-- can succeed.
Res := C_Listen (S0, 1);
if Res = Failure then
Err := Socket_Errno;
Res := C_Close (S0);
Raise_Socket_Error (Err);
end if;
S1 := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);
if S1 = Failure then
Err := Socket_Errno;
Res := C_Close (S0);
Raise_Socket_Error (Err);
end if;
-- Do a connect and accept the connection
Res := C_Connect (S1, Sin'Address, Len);
if Res = Failure then
Err := Socket_Errno;
Res := C_Close (S0);
Res := C_Close (S1);
Raise_Socket_Error (Err);
end if;
-- Since the call to connect(2) has suceeded and the backlog limit on
-- the listening socket is 1, we know that there is now exactly one
-- pending connection on S0, which is the one from S1.
S2 := C_Accept (S0, Sin'Address, Len'Access);
if S2 = Failure then
Err := Socket_Errno;
Res := C_Close (S0);
Res := C_Close (S1);
Raise_Socket_Error (Err);
end if;
Res := C_Close (S0);
Res := Signalling_Fds.Create (Two_Fds'Access);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
Selector.R_Sig_Socket := Socket_Type (S1);
Selector.W_Sig_Socket := Socket_Type (S2);
Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End));
Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End));
end Create_Selector;
-------------------
......@@ -1073,7 +985,7 @@ package body GNAT.Sockets is
is
use type C.unsigned_char;
V8 : aliased Two_Int;
V8 : aliased Two_Ints;
V4 : aliased C.int;
V1 : aliased C.unsigned_char;
VT : aliased Timeval;
......@@ -1899,7 +1811,7 @@ package body GNAT.Sockets is
Level : Level_Type := Socket_Level;
Option : Option_Type)
is
V8 : aliased Two_Int;
V8 : aliased Two_Ints;
V4 : aliased C.int;
V1 : aliased C.unsigned_char;
VT : aliased Timeval;
......
gcc/ada/g-socthi-mingw.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2005, AdaCore --
-- Copyright (C) 2001-2006, 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- --
......@@ -48,7 +48,7 @@ package body GNAT.Sockets.Thin is
WSAData_Dummy : array (1 .. 512) of C.int;
WS_Version : constant := 16#0101#;
WS_Version : constant := 16#0202#;
Initialized : Boolean := False;
SYSNOTREADY : constant := 10091;
......@@ -258,7 +258,7 @@ package body GNAT.Sockets.Thin is
-------------
function C_Readv
(Socket : C.int;
(Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int
is
......@@ -272,7 +272,7 @@ package body GNAT.Sockets.Thin is
begin
for J in Iovec'Range loop
Res := C_Recv
(Socket,
(Fd,
Iovec (J).Base.all'Address,
C.int (Iovec (J).Length),
0);
......@@ -434,7 +434,7 @@ package body GNAT.Sockets.Thin is
--------------
function C_Writev
(Socket : C.int;
(Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int
is
......@@ -448,7 +448,7 @@ package body GNAT.Sockets.Thin is
begin
for J in Iovec'Range loop
Res := C_Send
(Socket,
(Fd,
Iovec (J).Base.all'Address,
C.int (Iovec (J).Length),
0);
......@@ -478,7 +478,7 @@ package body GNAT.Sockets.Thin is
-- Initialize --
----------------
procedure Initialize (Process_Blocking_IO : Boolean := False) is
procedure Initialize (Process_Blocking_IO : Boolean) is
pragma Unreferenced (Process_Blocking_IO);
Return_Value : Interfaces.C.int;
......@@ -542,6 +542,12 @@ package body GNAT.Sockets.Thin is
Sin.Sin_Port := Port;
end Set_Port;
--------------------
-- Signalling_Fds --
--------------------
package body Signalling_Fds is separate;
--------------------------
-- Socket_Error_Message --
--------------------------
......
gcc/ada/g-socthi-mingw.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2005, AdaCore --
-- Copyright (C) 2001-2006, 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- --
......@@ -60,10 +60,9 @@ package GNAT.Sockets.Thin is
procedure Set_Socket_Errno (Errno : Integer);
-- Set last socket error number
function Socket_Error_Message
(Errno : Integer) return C.Strings.chars_ptr;
-- Returns the error message string for the error number Errno. If
-- Errno is not known it returns "Unknown system error".
function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
-- Returns the error message string for the error number Errno. If Errno is
-- not known it returns "Unknown system error".
function Host_Errno return Integer;
pragma Import (C, Host_Errno, "__gnat_get_h_errno");
......@@ -73,13 +72,13 @@ package GNAT.Sockets.Thin is
No_Fd_Set : constant Fd_Set_Access := System.Null_Address;
type time_t is
range -(2 ** (8 * Constants.SIZEOF_tv_sec - 1))
range -2 ** (8 * Constants.SIZEOF_tv_sec - 1)
.. 2 ** (8 * Constants.SIZEOF_tv_sec - 1) - 1;
for time_t'Size use 8 * Constants.SIZEOF_tv_sec;
pragma Convention (C, time_t);
type suseconds_t is
range -(2 ** (8 * Constants.SIZEOF_tv_usec - 1))
range -2 ** (8 * Constants.SIZEOF_tv_usec - 1)
.. 2 ** (8 * Constants.SIZEOF_tv_usec - 1) - 1;
for suseconds_t'Size use 8 * Constants.SIZEOF_tv_usec;
pragma Convention (C, suseconds_t);
......@@ -123,6 +122,7 @@ package GNAT.Sockets.Thin is
type In_Addr_Access_Array is array (C.size_t range <>)
of aliased In_Addr_Access;
pragma Convention (C, In_Addr_Access_Array);
package In_Addr_Access_Pointers is
new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null);
-- Array of internet addresses
......@@ -203,14 +203,24 @@ package GNAT.Sockets.Thin is
pragma Convention (C, Servent_Access);
-- Access to service entry
type Two_Int is array (0 .. 1) of C.int;
pragma Convention (C, Two_Int);
-- Used with pipe()
type Two_Ints is array (0 .. 1) of C.int;
pragma Convention (C, Two_Ints);
-- Container for two int values
subtype Fd_Pair is Two_Ints;
-- Two_Ints as used for Create_Signalling_Fds: a pair of connected file
-- descriptors, one of which (the "read end" of the connection) being used
-- for reading, the other one (the "write end") being used for writing.
Read_End : constant := 0;
Write_End : constant := 1;
-- Indices into an Fd_Pair value providing access to each of the connected
-- file descriptors.
function C_Accept
(S : C.int;
Addr : System.Address;
Addrlen : access C.int) return C.int;
Addrlen : not null access C.int) return C.int;
function C_Bind
(S : C.int;
......@@ -227,7 +237,7 @@ package GNAT.Sockets.Thin is
function C_Gethostbyaddr
(Addr : System.Address;
Length : C.int;
Len : C.int;
Typ : C.int) return Hostent_Access;
function C_Gethostbyname
......@@ -240,7 +250,7 @@ package GNAT.Sockets.Thin is
function C_Getpeername
(S : C.int;
Name : System.Address;
Namelen : access C.int) return C.int;
Namelen : not null access C.int) return C.int;
function C_Getservbyname
(Name : C.char_array;
......@@ -253,14 +263,14 @@ package GNAT.Sockets.Thin is
function C_Getsockname
(S : C.int;
Name : System.Address;
Namelen : access C.int) return C.int;
Namelen : not null access C.int) return C.int;
function C_Getsockopt
(S : C.int;
Level : C.int;
Optname : C.int;
Optval : System.Address;
Optlen : access C.int) return C.int;
Optlen : not null access C.int) return C.int;
function C_Inet_Addr
(Cp : C.Strings.chars_ptr) return C.int;
......@@ -275,23 +285,23 @@ package GNAT.Sockets.Thin is
Backlog : C.int) return C.int;
function C_Readv
(Socket : C.int;
(Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int;
function C_Recv
(S : C.int;
Buf : System.Address;
Msg : System.Address;
Len : C.int;
Flags : C.int) return C.int;
function C_Recvfrom
(S : C.int;
Buf : System.Address;
Msg : System.Address;
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int;
Fromlen : not null access C.int) return C.int;
function C_Select
(Nfds : C.int;
......@@ -302,7 +312,7 @@ package GNAT.Sockets.Thin is
function C_Send
(S : C.int;
Buf : System.Address;
Msg : System.Address;
Len : C.int;
Flags : C.int) return C.int;
......@@ -337,7 +347,7 @@ package GNAT.Sockets.Thin is
(Command : System.Address) return C.int;
function C_Writev
(Socket : C.int;
(Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int;
......@@ -345,6 +355,25 @@ package GNAT.Sockets.Thin is
(WS_Version : Interfaces.C.int;
WSADataAddress : System.Address) return Interfaces.C.int;
package Signalling_Fds is
function Create (Fds : not null access Fd_Pair) return C.int;
pragma Convention (C, Create);
-- Create a pair of connected descriptors suitable for use with C_Select
-- (used for signalling in Selector objects).
function Read (Rsig : C.int) return C.int;
pragma Convention (C, Read);
-- Read one byte of data from rsig, the read end of a pair of signalling
-- fds created by Create_Signalling_Fds.
function Write (Wsig : C.int) return C.int;
pragma Convention (C, Write);
-- Write one byte of data to wsig, the write end of a pair of signalling
-- fds created by Create_Signalling_Fds.
end Signalling_Fds;
procedure Free_Socket_Set
(Set : Fd_Set_Access);
-- Free system-dependent socket set
......@@ -373,17 +402,17 @@ package GNAT.Sockets.Thin is
procedure Last_Socket_In_Set
(Set : Fd_Set_Access;
Last : Int_Access);
-- Find the largest socket in the socket set. This is needed for
-- select(). When Last_Socket_In_Set is called, parameter Last is
-- a maximum value of the largest socket. This hint is used to
-- avoid scanning very large socket sets. After the call, Last is
-- set back to the real largest socket in the socket set.
-- Find the largest socket in the socket set. This is needed for select().
-- When Last_Socket_In_Set is called, parameter Last is a maximum value of
-- the largest socket. This hint is used to avoid scanning very large
-- socket sets. After the call, Last is set back to the real largest socket
-- in the socket set.
function New_Socket_Set
(Set : Fd_Set_Access) return Fd_Set_Access;
-- Allocate a new socket set which is a system-dependent structure
-- and initialize by copying Set if it is non-null, by making it
-- empty otherwise.
-- Allocate a new socket set which is a system-dependent structure and
-- initialize by copying Set if it is non-null, by making it empty
-- otherwise.
procedure Remove_Socket_From_Set
(Set : Fd_Set_Access;
......@@ -393,7 +422,7 @@ package GNAT.Sockets.Thin is
procedure WSACleanup;
procedure Finalize;
procedure Initialize (Process_Blocking_IO : Boolean := False);
procedure Initialize (Process_Blocking_IO : Boolean);
private
pragma Import (Stdcall, C_Accept, "accept");
......@@ -430,4 +459,5 @@ private
pragma Import (C, New_Socket_Set, "__gnat_new_socket_set");
pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set");
pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set");
end GNAT.Sockets.Thin;
gcc/ada/g-socthi-vms.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2005, AdaCore --
-- Copyright (C) 2001-2006, 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- --
......@@ -64,7 +64,7 @@ package body GNAT.Sockets.Thin is
function Syscall_Accept
(S : C.int;
Addr : System.Address;
Addrlen : access C.int) return C.int;
Addrlen : not null access C.int) return C.int;
pragma Import (C, Syscall_Accept, "accept");
function Syscall_Connect
......@@ -92,7 +92,7 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int;
Fromlen : not null access C.int) return C.int;
pragma Import (C, Syscall_Recvfrom, "recvfrom");
function Syscall_Send
......@@ -125,7 +125,7 @@ package body GNAT.Sockets.Thin is
function C_Accept
(S : C.int;
Addr : System.Address;
Addrlen : access C.int) return C.int
Addrlen : not null access C.int) return C.int
is
R : C.int;
Val : aliased C.int := 1;
......@@ -275,7 +275,7 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int
Fromlen : not null access C.int) return C.int
is
Res : C.int;
......@@ -461,6 +461,12 @@ package body GNAT.Sockets.Thin is
Sin.Sin_Port := Port;
end Set_Port;
--------------------
-- Signalling_Fds --
--------------------
package body Signalling_Fds is separate;
--------------------------
-- Socket_Error_Message --
--------------------------
......
gcc/ada/g-socthi-vms.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2005, AdaCore --
-- Copyright (C) 2002-2006, 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- --
......@@ -38,8 +38,8 @@
-- This is the Alpha/VMS version
with Interfaces.C.Pointers;
with Interfaces.C.Strings;
with GNAT.Sockets.Constants;
with GNAT.OS_Lib;
......@@ -60,9 +60,12 @@ package GNAT.Sockets.Thin is
function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
-- Returns last socket error number
procedure Set_Socket_Errno (Errno : Integer) renames GNAT.OS_Lib.Set_Errno;
-- Set last socket error number
function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
-- Returns the error message string for the error number Errno. If
-- Errno is not known it returns "Unknown system error".
-- Returns the error message string for the error number Errno. If Errno is
-- not known it returns "Unknown system error".
function Host_Errno return Integer;
pragma Import (C, Host_Errno, "__gnat_get_h_errno");
......@@ -203,14 +206,24 @@ package GNAT.Sockets.Thin is
pragma Convention (C, Servent_Access);
-- Access to service entry
type Two_Int is array (0 .. 1) of C.int;
pragma Convention (C, Two_Int);
-- Used with pipe()
type Two_Ints is array (0 .. 1) of C.int;
pragma Convention (C, Two_Ints);
-- Container for two int values
subtype Fd_Pair is Two_Ints;
-- Two_Ints as used for Create_Signalling_Fds: a pair of connected file
-- descriptors, one of which (the "read end" of the connection) being used
-- for reading, the other one (the "write end") being used for writing.
Read_End : constant := 0;
Write_End : constant := 1;
-- Indices into an Fd_Pair value providing access to each of the connected
-- file descriptors.
function C_Accept
(S : C.int;
Addr : System.Address;
Addrlen : access C.int) return C.int;
Addrlen : not null access C.int) return C.int;
function C_Bind
(S : C.int;
......@@ -240,7 +253,7 @@ package GNAT.Sockets.Thin is
function C_Getpeername
(S : C.int;
Name : System.Address;
Namelen : access C.int) return C.int;
Namelen : not null access C.int) return C.int;
function C_Getservbyname
(Name : C.char_array;
......@@ -253,14 +266,14 @@ package GNAT.Sockets.Thin is
function C_Getsockname
(S : C.int;
Name : System.Address;
Namelen : access C.int) return C.int;
Namelen : not null access C.int) return C.int;
function C_Getsockopt
(S : C.int;
Level : C.int;
Optname : C.int;
Optval : System.Address;
Optlen : access C.int) return C.int;
Optlen : not null access C.int) return C.int;
function C_Inet_Addr
(Cp : C.Strings.chars_ptr) return C.int;
......@@ -270,7 +283,9 @@ package GNAT.Sockets.Thin is
Req : C.int;
Arg : Int_Access) return C.int;
function C_Listen (S, Backlog : C.int) return C.int;
function C_Listen
(S : C.int;
Backlog : C.int) return C.int;
function C_Readv
(Fd : C.int;
......@@ -289,7 +304,7 @@ package GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int;
Fromlen : not null access C.int) return C.int;
function C_Select
(Nfds : C.int;
......@@ -339,6 +354,25 @@ package GNAT.Sockets.Thin is
Iov : System.Address;
Iovcnt : C.int) return C.int;
package Signalling_Fds is
function Create (Fds : not null access Fd_Pair) return C.int;
pragma Convention (C, Create);
-- Create a pair of connected descriptors suitable for use with C_Select
-- (used for signalling in Selector objects).
function Read (Rsig : C.int) return C.int;
pragma Convention (C, Read);
-- Read one byte of data from rsig, the read end of a pair of signalling
-- fds created by Create_Signalling_Fds.
function Write (Wsig : C.int) return C.int;
pragma Convention (C, Write);
-- Write one byte of data to wsig, the write end of a pair of signalling
-- fds created by Create_Signalling_Fds.
end Signalling_Fds;
procedure Free_Socket_Set
(Set : Fd_Set_Access);
-- Free system-dependent socket set
......@@ -367,17 +401,17 @@ package GNAT.Sockets.Thin is
procedure Last_Socket_In_Set
(Set : Fd_Set_Access;
Last : Int_Access);
-- Find the largest socket in the socket set. This is needed for
-- select(). When Last_Socket_In_Set is called, parameter Last is
-- a maximum value of the largest socket. This hint is used to
-- avoid scanning very large socket sets. After the call, Last is
-- set back to the real largest socket in the socket set.
-- Find the largest socket in the socket set. This is needed for select().
-- When Last_Socket_In_Set is called, parameter Last is a maximum value of
-- the largest socket. This hint is used to avoid scanning very large
-- socket sets. After the call, Last is set back to the real largest socket
-- in the socket set.
function New_Socket_Set
(Set : Fd_Set_Access) return Fd_Set_Access;
-- Allocate a new socket set which is a system-dependent structure
-- and initialize by copying Set if it is non-null, by making it
-- empty otherwise.
-- Allocate a new socket set which is a system-dependent structure and
-- initialize by copying Set if it is non-null, by making it empty
-- otherwise.
procedure Remove_Socket_From_Set
(Set : Fd_Set_Access;
......@@ -414,4 +448,5 @@ private
pragma Import (C, New_Socket_Set, "__gnat_new_socket_set");
pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set");
pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set");
end GNAT.Sockets.Thin;
gcc/ada/g-socthi-vxworks.adb
......@@ -92,7 +92,7 @@ package body GNAT.Sockets.Thin is
function Syscall_Accept
(S : C.int;
Addr : System.Address;
Addrlen : access C.int) return C.int;
Addrlen : not null access C.int) return C.int;
pragma Import (C, Syscall_Accept, "accept");
function Syscall_Connect
......@@ -120,7 +120,7 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int;
Fromlen : not null access C.int) return C.int;
pragma Import (C, Syscall_Recvfrom, "recvfrom");
function Syscall_Send
......@@ -155,7 +155,7 @@ package body GNAT.Sockets.Thin is
function C_Accept
(S : C.int;
Addr : System.Address;
Addrlen : access C.int) return C.int
Addrlen : not null access C.int) return C.int
is
R : C.int;
Val : aliased C.int := 1;
......@@ -398,7 +398,7 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int
Fromlen : not null access C.int) return C.int
is
Res : C.int;
......@@ -594,6 +594,12 @@ package body GNAT.Sockets.Thin is
Sin.Sin_Port := Port;
end Set_Port;
--------------------
-- Signalling_Fds --
--------------------
package body Signalling_Fds is separate;
--------------------------
-- Socket_Error_Message --
--------------------------
......
gcc/ada/g-socthi-vxworks.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2005, AdaCore --
-- Copyright (C) 2002-2006, 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- --
......@@ -38,9 +38,10 @@
-- This is the version for VxWorks
with Interfaces.C.Pointers;
with Interfaces.C.Strings;
with Ada.Unchecked_Conversion;
with Interfaces.C.Strings;
with GNAT.Sockets.Constants;
with GNAT.OS_Lib;
......@@ -59,6 +60,9 @@ package GNAT.Sockets.Thin is
function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
-- Returns last socket error number
procedure Set_Socket_Errno (Errno : Integer) renames GNAT.OS_Lib.Set_Errno;
-- Set last socket error number
function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
-- Returns the error message string for the error number Errno. If Errno is
-- not known it returns "Unknown system error".
......@@ -205,14 +209,24 @@ package GNAT.Sockets.Thin is
pragma Convention (C, Servent_Access);
-- Access to service entry
type Two_Int is array (0 .. 1) of C.int;
pragma Convention (C, Two_Int);
-- Used with pipe()
type Two_Ints is array (0 .. 1) of C.int;
pragma Convention (C, Two_Ints);
-- Container for two int values
subtype Fd_Pair is Two_Ints;
-- Two_Ints as used for Create_Signalling_Fds: a pair of connected file
-- descriptors, one of which (the "read end" of the connection) being used
-- for reading, the other one (the "write end") being used for writing.
Read_End : constant := 0;
Write_End : constant := 1;
-- Indices into an Fd_Pair value providing access to each of the connected
-- file descriptors.
function C_Accept
(S : C.int;
Addr : System.Address;
Addrlen : access C.int) return C.int;
Addrlen : not null access C.int) return C.int;
function C_Bind
(S : C.int;
......@@ -242,7 +256,7 @@ package GNAT.Sockets.Thin is
function C_Getpeername
(S : C.int;
Name : System.Address;
Namelen : access C.int) return C.int;
Namelen : not null access C.int) return C.int;
function C_Getservbyname
(Name : C.char_array;
......@@ -255,14 +269,14 @@ package GNAT.Sockets.Thin is
function C_Getsockname
(S : C.int;
Name : System.Address;
Namelen : access C.int) return C.int;
Namelen : not null access C.int) return C.int;
function C_Getsockopt
(S : C.int;
Level : C.int;
Optname : C.int;
Optval : System.Address;
Optlen : access C.int) return C.int;
Optlen : not null access C.int) return C.int;
function C_Inet_Addr
(Cp : C.Strings.chars_ptr) return C.int;
......@@ -272,7 +286,9 @@ package GNAT.Sockets.Thin is
Req : C.int;
Arg : Int_Access) return C.int;
function C_Listen (S, Backlog : C.int) return C.int;
function C_Listen
(S : C.int;
Backlog : C.int) return C.int;
function C_Readv
(Fd : C.int;
......@@ -291,7 +307,7 @@ package GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int;
Fromlen : not null access C.int) return C.int;
function C_Select
(Nfds : C.int;
......@@ -341,6 +357,25 @@ package GNAT.Sockets.Thin is
Iov : System.Address;
Iovcnt : C.int) return C.int;
package Signalling_Fds is
function Create (Fds : not null access Fd_Pair) return C.int;
pragma Convention (C, Create);
-- Create a pair of connected descriptors suitable for use with C_Select
-- (used for signalling in Selector objects).
function Read (Rsig : C.int) return C.int;
pragma Convention (C, Read);
-- Read one byte of data from rsig, the read end of a pair of signalling
-- fds created by Create_Signalling_Fds.
function Write (Wsig : C.int) return C.int;
pragma Convention (C, Write);
-- Write one byte of data to wsig, the write end of a pair of signalling
-- fds created by Create_Signalling_Fds.
end Signalling_Fds;
procedure Free_Socket_Set
(Set : Fd_Set_Access);
-- Free system-dependent socket set
......@@ -369,17 +404,17 @@ package GNAT.Sockets.Thin is
procedure Last_Socket_In_Set
(Set : Fd_Set_Access;
Last : Int_Access);
-- Find the largest socket in the socket set. This is needed for
-- select(). When Last_Socket_In_Set is called, parameter Last is
-- a maximum value of the largest socket. This hint is used to
-- avoid scanning very large socket sets. After the call, Last is
-- set back to the real largest socket in the socket set.
-- Find the largest socket in the socket set. This is needed for select().
-- When Last_Socket_In_Set is called, parameter Last is a maximum value of
-- the largest socket. This hint is used to avoid scanning very large
-- socket sets. After the call, Last is set back to the real largest socket
-- in the socket set.
function New_Socket_Set
(Set : Fd_Set_Access) return Fd_Set_Access;
-- Allocate a new socket set which is a system-dependent structure
-- and initialize by copying Set if it is non-null, by making it
-- empty otherwise.
-- Allocate a new socket set which is a system-dependent structure and
-- initialize by copying Set if it is non-null, by making it empty
-- otherwise.
procedure Remove_Socket_From_Set
(Set : Fd_Set_Access;
......@@ -390,7 +425,6 @@ package GNAT.Sockets.Thin is
procedure Initialize (Process_Blocking_IO : Boolean);
private
pragma Import (C, C_Bind, "bind");
pragma Import (C, C_Close, "close");
pragma Import (C, C_Gethostname, "gethostname");
......
gcc/ada/g-socthi.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2005, AdaCore --
-- Copyright (C) 2001-2006, 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- --
......@@ -71,7 +71,7 @@ package body GNAT.Sockets.Thin is
function Syscall_Accept
(S : C.int;
Addr : System.Address;
Addrlen : access C.int) return C.int;
Addrlen : not null access C.int) return C.int;
pragma Import (C, Syscall_Accept, "accept");
function Syscall_Connect
......@@ -99,7 +99,7 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int;
Fromlen : not null access C.int) return C.int;
pragma Import (C, Syscall_Recvfrom, "recvfrom");
function Syscall_Send
......@@ -127,6 +127,11 @@ package body GNAT.Sockets.Thin is
procedure Disable_SIGPIPE (S : C.int);
pragma Import (C, Disable_SIGPIPE, "__gnat_disable_sigpipe");
procedure Disable_All_SIGPIPEs;
pragma Import (C, Disable_All_SIGPIPEs, "__gnat_disable_all_sigpipes");
-- Sets the process to ignore all SIGPIPE signals on platforms that
-- don't support Disable_SIGPIPE for particular streams.
function Non_Blocking_Socket (S : C.int) return Boolean;
procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
......@@ -137,7 +142,7 @@ package body GNAT.Sockets.Thin is
function C_Accept
(S : C.int;
Addr : System.Address;
Addrlen : access C.int) return C.int
Addrlen : not null access C.int) return C.int
is
R : C.int;
Val : aliased C.int := 1;
......@@ -288,7 +293,7 @@ package body GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int
Fromlen : not null access C.int) return C.int
is
Res : C.int;
......@@ -404,6 +409,7 @@ package body GNAT.Sockets.Thin is
procedure Initialize (Process_Blocking_IO : Boolean) is
begin
Thread_Blocking_IO := not Process_Blocking_IO;
Disable_All_SIGPIPEs;
end Initialize;
-------------------------
......@@ -487,6 +493,32 @@ package body GNAT.Sockets.Thin is
Sin.Sin_Port := Port;
end Set_Port;
--------------------
-- Signalling_Fds --
--------------------
package body Signalling_Fds is
-- In this default implementation, we use a C version of these
-- subprograms provided by socket.c.
function C_Create (Fds : not null access Fd_Pair) return C.int;
function C_Read (Rsig : C.int) return C.int;
function C_Write (Wsig : C.int) return C.int;
pragma Import (C, C_Create, "__gnat_create_signalling_fds");
pragma Import (C, C_Read, "__gnat_read_signalling_fd");
pragma Import (C, C_Write, "__gnat_write_signalling_fd");
function Create (Fds : not null access Fd_Pair) return C.int
renames C_Create;
function Read (Rsig : C.int) return C.int renames C_Read;
function Write (Wsig : C.int) return C.int renames C_Write;
end Signalling_Fds;
--------------------------
-- Socket_Error_Message --
--------------------------
......
gcc/ada/g-socthi.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2005, AdaCore --
-- Copyright (C) 2001-2006, 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- --
......@@ -39,6 +39,7 @@
with Interfaces.C.Pointers;
with Interfaces.C.Strings;
with GNAT.Sockets.Constants;
with GNAT.OS_Lib;
......@@ -204,14 +205,24 @@ package GNAT.Sockets.Thin is
pragma Convention (C, Servent_Access);
-- Access to service entry
type Two_Int is array (0 .. 1) of C.int;
pragma Convention (C, Two_Int);
-- Used with pipe()
type Two_Ints is array (0 .. 1) of C.int;
pragma Convention (C, Two_Ints);
-- Container for two int values
subtype Fd_Pair is Two_Ints;
-- Two_Ints as used for Create_Signalling_Fds: a pair of connected file
-- descriptors, one of which (the "read end" of the connection) being used
-- for reading, the other one (the "write end") being used for writing.
Read_End : constant := 0;
Write_End : constant := 1;
-- Indices into an Fd_Pair value providing access to each of the connected
-- file descriptors.
function C_Accept
(S : C.int;
Addr : System.Address;
Addrlen : access C.int) return C.int;
Addrlen : not null access C.int) return C.int;
function C_Bind
(S : C.int;
......@@ -241,7 +252,7 @@ package GNAT.Sockets.Thin is
function C_Getpeername
(S : C.int;
Name : System.Address;
Namelen : access C.int) return C.int;
Namelen : not null access C.int) return C.int;
function C_Getservbyname
(Name : C.char_array;
......@@ -254,14 +265,14 @@ package GNAT.Sockets.Thin is
function C_Getsockname
(S : C.int;
Name : System.Address;
Namelen : access C.int) return C.int;
Namelen : not null access C.int) return C.int;
function C_Getsockopt
(S : C.int;
Level : C.int;
Optname : C.int;
Optval : System.Address;
Optlen : access C.int) return C.int;
Optlen : not null access C.int) return C.int;
function C_Inet_Addr
(Cp : C.Strings.chars_ptr) return C.int;
......@@ -292,7 +303,7 @@ package GNAT.Sockets.Thin is
Len : C.int;
Flags : C.int;
From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int;
Fromlen : not null access C.int) return C.int;
function C_Select
(Nfds : C.int;
......@@ -342,6 +353,25 @@ package GNAT.Sockets.Thin is
Iov : System.Address;
Iovcnt : C.int) return C.int;
package Signalling_Fds is
function Create (Fds : not null access Fd_Pair) return C.int;
pragma Convention (C, Create);
-- Create a pair of connected descriptors suitable for use with C_Select
-- (used for signalling in Selector objects).
function Read (Rsig : C.int) return C.int;
pragma Convention (C, Read);
-- Read one byte of data from rsig, the read end of a pair of signalling
-- fds created by Create_Signalling_Fds.
function Write (Wsig : C.int) return C.int;
pragma Convention (C, Write);
-- Write one byte of data to wsig, the write end of a pair of signalling
-- fds created by Create_Signalling_Fds.
end Signalling_Fds;
procedure Free_Socket_Set
(Set : Fd_Set_Access);
-- Free system-dependent socket set
......@@ -418,4 +448,5 @@ private
pragma Import (C, New_Socket_Set, "__gnat_new_socket_set");
pragma Import (C, Insert_Socket_In_Set, "__gnat_insert_socket_in_set");
pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set");
end GNAT.Sockets.Thin;
gcc/ada/g-soliop-mingw.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2005, AdaCore --
-- Copyright (C) 2001-2006, 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- --
......@@ -38,5 +38,5 @@
package GNAT.Sockets.Linker_Options is
private
pragma Linker_Options ("-lwsock32");
pragma Linker_Options ("-lws2_32");
end GNAT.Sockets.Linker_Options;
gcc/ada/g-stsifd-sockets.adb 0 → 100644
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- G N A T . S O C K E T S . T H I N . S I G N A L L I N G _ F D S --
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2006, 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 2, 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. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
-- Boston, MA 02110-1301, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
-- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- Portable sockets-based implementation of GNAT.Sockets.Thin.Signalling_Fds
-- used for platforms that do not support UNIX pipes.
-- Note: this code used to be in GNAT.Sockets, but has been moved to a
-- platform-specific file. It is now used only for non-UNIX platforms.
separate
(GNAT.Sockets.Thin)
package body Signalling_Fds is
------------
-- Create --
------------
function Create (Fds : not null access Fd_Pair) return C.int is
L_Sock, R_Sock, W_Sock : C.int := Failure;
-- Listening socket, read socket and write socket
Sin : aliased Sockaddr_In;
Len : aliased C.int := Sin'Size / 8;
-- Address of listening socket
Res : C.int;
-- Return status of system calls
Err : Integer;
-- Saved errno value
begin
Fds (Read_End) := Failure;
Fds (Write_End) := Failure;
-- We open two signalling sockets. One of them is used to send data
-- to the other, which is included in a C_Select socket set. The
-- communication is used to force the call to C_Select to complete,
-- and the waiting task to resume its execution.
-- Create a listening socket
L_Sock := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);
if L_Sock = Failure then
goto Fail;
end if;
-- Bind the socket to an available port on localhost
Sin.Sin_Addr.S_B1 := 127;
Sin.Sin_Addr.S_B2 := 0;
Sin.Sin_Addr.S_B3 := 0;
Sin.Sin_Addr.S_B4 := 1;
Sin.Sin_Port := 0;
Res := C_Bind (L_Sock, Sin'Address, Len);
if Res = Failure then
goto Fail;
end if;
-- Get assigned port
Res := C_Getsockname (L_Sock, Sin'Address, Len'Access);
if Res = Failure then
goto Fail;
end if;
-- Set socket to listen mode, with a backlog of 1 to guarantee that
-- exactly one call to connect(2) succeeds.
Res := C_Listen (L_Sock, 1);
if Res = Failure then
goto Fail;
end if;
-- Create read end (client) socket
R_Sock := C_Socket (Constants.AF_INET, Constants.SOCK_STREAM, 0);
if R_Sock = Failure then
goto Fail;
end if;
-- Connect listening socket
Res := C_Connect (R_Sock, Sin'Address, Len);
if Res = Failure then
goto Fail;
end if;
-- Since the call to connect(2) has suceeded and the backlog limit on
-- the listening socket is 1, we know that there is now exactly one
-- pending connection on L_Sock, which is the one from R_Sock.
W_Sock := C_Accept (L_Sock, Sin'Address, Len'Access);
if W_Sock = Failure then
goto Fail;
end if;
-- Set TCP_NODELAY on W_Sock, since we always want to send the data out
-- immediately.
Set_Socket_Option
(Socket => Socket_Type (W_Sock),
Level => IP_Protocol_For_TCP_Level,
Option => (Name => No_Delay, Enabled => True));
-- Close listening socket (ignore exit status)
Res := C_Close (L_Sock);
Fds (Read_End) := R_Sock;
Fds (Write_End) := W_Sock;
return Success;
<<Fail>>
Err := Socket_Errno;
if W_Sock /= Failure then
Res := C_Close (W_Sock);
end if;
if R_Sock /= Failure then
Res := C_Close (R_Sock);
end if;
if L_Sock /= Failure then
Res := C_Close (L_Sock);
end if;
Set_Socket_Errno (Err);
return Failure;
end Create;
----------
-- Read --
----------
function Read (Rsig : C.int) return C.int is
Buf : aliased Character;
begin
return C_Recv (Rsig, Buf'Address, 1, Constants.MSG_Forced_Flags);
end Read;
-----------
-- Write --
-----------
function Write (Wsig : C.int) return C.int is
Buf : aliased Character := ASCII.NUL;
begin
return C_Send (Wsig, Buf'Address, 1, Constants.MSG_Forced_Flags);
end Write;
end Signalling_Fds;
gcc/ada/socket.c
......@@ -6,7 +6,7 @@
* *
* C Implementation File *
* *
* Copyright (C) 2003-2005 Free Software Foundation, Inc. *
* Copyright (C) 2003-2006, Free Software Foundation, Inc. *
* *
* 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- *
......@@ -36,6 +36,11 @@
/* Include all the necessary system-specific headers and define the
necessary macros (shared with gen-soccon). */
#if !defined(SO_NOSIGPIPE) && !defined (MSG_NOSIGNAL)
#include <signal.h>
#endif
/* Required if we will be calling signal() in __gnat_disable_all_sigpipes() */
#include "raise.h"
/* Required for __gnat_malloc() */
......@@ -43,6 +48,10 @@
/* Required for memcpy() */
extern void __gnat_disable_sigpipe (int fd);
extern void __gnat_disable_all_sigpipes (void);
extern int __gnat_create_signalling_fds (int *fds);
extern int __gnat_read_signalling_fd (int rsig);
extern int __gnat_write_signalling_fd (int wsig);
extern void __gnat_free_socket_set (fd_set *);
extern void __gnat_last_socket_in_set (fd_set *, int *);
extern void __gnat_get_socket_from_set (fd_set *, int *, int *);
......@@ -63,6 +72,51 @@ __gnat_disable_sigpipe (int fd)
#endif
}
void
__gnat_disable_all_sigpipes (void)
{
#if !defined(SO_NOSIGPIPE) && !defined(MSG_NOSIGNAL) && defined(SIGPIPE)
(void) signal (SIGPIPE, SIG_IGN);
#endif
}
#if defined (_WIN32) || defined (__vxworks) || defined (VMS)
/*
* Signalling FDs operations are implemented in Ada for these platforms
* (see subunit GNAT.Sockets.Thin.Signalling_Fds).
*/
#else
/*
* Create a pair of connected file descriptors fds[0] and fds[1] used for
* signalling by a Selector object. fds[0] is the read end, and fds[1] the
* write end.
*/
int
__gnat_create_signalling_fds (int *fds) {
return pipe (fds);
}
/*
* Read one byte of data from rsig, the read end of a pair of signalling fds
* created by __gnat_create_signalling_fds.
*/
int
__gnat_read_signalling_fd (int rsig) {
char c;
return read (rsig, &c, 1);
}
/*
* Write one byte of data to wsig, the write end of a pair of signalling fds
* created by __gnat_create_signalling_fds.
*/
int
__gnat_write_signalling_fd (int wsig) {
char c = 0;
return write (wsig, &c, 1);
}
#endif
/* Free socket set. */
void
......@@ -83,7 +137,7 @@ __gnat_last_socket_in_set (fd_set *set, int *last)
int l;
l = -1;
#ifdef WINNT
#ifdef _WIN32
/* More efficient method for NT. */
for (s = 0; s < set->fd_count; s++)
if ((int) set->fd_array[s] > l)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment