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 1156 additions and 248 deletions
gcc/ada/Makefile.in
# Makefile for GNU Ada Compiler (GNAT). # 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. #This file is part of GCC.
...@@ -409,6 +409,7 @@ ifeq ($(strip $(filter-out m68k% wrs vx%,$(targ))),) ...@@ -409,6 +409,7 @@ ifeq ($(strip $(filter-out m68k% wrs vx%,$(targ))),)
g-soccon.ads<g-soccon-vxworks.ads \ g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<g-socthi-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 \
system.ads<system-vxworks-m68k.ads system.ads<system-vxworks-m68k.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
...@@ -444,7 +445,8 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),) ...@@ -444,7 +445,8 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworks,$(targ))),)
s-vxwork.ads<s-vxwork-ppc.ads \ s-vxwork.ads<s-vxwork-ppc.ads \
g-soccon.ads<g-soccon-vxworks.ads \ g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<g-socthi-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 TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
...@@ -501,6 +503,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(targ))),) ...@@ -501,6 +503,7 @@ ifeq ($(strip $(filter-out powerpc% wrs vxworksae,$(targ))),)
g-soccon.ads<g-soccon-vxworks.ads \ g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<g-socthi-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 \
system.ads<system-vxworks-ppc-vthread.ads system.ads<system-vxworks-ppc-vthread.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
...@@ -546,6 +549,7 @@ ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),) ...@@ -546,6 +549,7 @@ ifeq ($(strip $(filter-out sparc% wrs vx%,$(targ))),)
g-soccon.ads<g-soccon-vxworks.ads \ g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<g-socthi-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 \
system.ads<system-vxworks-sparcv9.ads \ system.ads<system-vxworks-sparcv9.ads \
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
...@@ -572,9 +576,11 @@ ifeq ($(strip $(filter-out %86 wrs vxworks,$(targ))),) ...@@ -572,9 +576,11 @@ ifeq ($(strip $(filter-out %86 wrs vxworks,$(targ))),)
s-taprop.adb<s-taprop-vxworks.adb \ s-taprop.adb<s-taprop-vxworks.adb \
s-taspri.ads<s-taspri-vxworks.ads \ s-taspri.ads<s-taspri-vxworks.ads \
s-vxwork.ads<s-vxwork-x86.ads \ s-vxwork.ads<s-vxwork-x86.ads \
g-bytswa.adb<g-bytswa-x86.adb \
g-soccon.ads<g-soccon-vxworks.ads \ g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<g-socthi-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 TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
...@@ -627,6 +633,7 @@ ifeq ($(strip $(filter-out arm% coff wrs vx%,$(targ))),) ...@@ -627,6 +633,7 @@ ifeq ($(strip $(filter-out arm% coff wrs vx%,$(targ))),)
g-soccon.ads<g-soccon-vxworks.ads \ g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<g-socthi-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 \
system.ads<system-vxworks-arm.ads system.ads<system-vxworks-arm.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
...@@ -656,6 +663,7 @@ ifeq ($(strip $(filter-out mips% wrs vx%,$(targ))),) ...@@ -656,6 +663,7 @@ ifeq ($(strip $(filter-out mips% wrs vx%,$(targ))),)
g-soccon.ads<g-soccon-vxworks.ads \ g-soccon.ads<g-soccon-vxworks.ads \
g-socthi.ads<g-socthi-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 \
system.ads<system-vxworks-mips.ads system.ads<system-vxworks-mips.ads
TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb TOOLS_TARGET_PAIRS=mlib-tgt.adb<mlib-tgt-vxworks.adb
...@@ -752,6 +760,7 @@ ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),) ...@@ -752,6 +760,7 @@ ifeq ($(strip $(filter-out %86 solaris2%,$(arch) $(osys))),)
s-tasinf.ads<s-tasinf-solaris.ads \ s-tasinf.ads<s-tasinf-solaris.ads \
s-taspri.ads<s-taspri-solaris.ads \ s-taspri.ads<s-taspri-solaris.ads \
s-tpopsp.adb<s-tpopsp-solaris.adb \ s-tpopsp.adb<s-tpopsp-solaris.adb \
g-bytswa.adb<g-bytswa-x86.adb \
g-soccon.ads<g-soccon-solaris.ads \ g-soccon.ads<g-soccon-solaris.ads \
g-soliop.ads<g-soliop-solaris.ads \ g-soliop.ads<g-soliop-solaris.ads \
system.ads<system-solaris-x86.ads system.ads<system-solaris-x86.ads
...@@ -772,6 +781,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),) ...@@ -772,6 +781,7 @@ ifeq ($(strip $(filter-out %86 linux%,$(arch) $(osys))),)
a-intnam.ads<a-intnam-linux.ads \ a-intnam.ads<a-intnam-linux.ads \
a-numaux.adb<a-numaux-x86.adb \ a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<a-numaux-x86.ads \ a-numaux.ads<a-numaux-x86.ads \
g-bytswa.adb<g-bytswa-x86.adb \
g-soccon.ads<g-soccon-linux-x86.ads \ g-soccon.ads<g-soccon-linux-x86.ads \
s-inmaop.adb<s-inmaop-posix.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \ s-intman.adb<s-intman-posix.adb \
...@@ -828,6 +838,7 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),) ...@@ -828,6 +838,7 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),)
a-intnam.ads<a-intnam-freebsd.ads \ a-intnam.ads<a-intnam-freebsd.ads \
a-numaux.adb<a-numaux-x86.adb \ a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<a-numaux-x86.ads \ a-numaux.ads<a-numaux-x86.ads \
g-bytswa.adb<g-bytswa-x86.adb \
g-soccon.ads<g-soccon-freebsd.ads \ g-soccon.ads<g-soccon-freebsd.ads \
s-inmaop.adb<s-inmaop-posix.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \ s-intman.adb<s-intman-posix.adb \
...@@ -844,7 +855,7 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),) ...@@ -844,7 +855,7 @@ ifeq ($(strip $(filter-out %86 freebsd%,$(arch) $(osys))),)
GNATLIB_SHARED = gnatlib-shared-dual GNATLIB_SHARED = gnatlib-shared-dual
EH_MECHANISM=-gcc EH_MECHANISM=-gcc
THREADSLIB= -lc_r THREADSLIB= -lpthread
GMEM_LIB = gmemlib GMEM_LIB = gmemlib
PREFIX_OBJS = $(PREFIX_REAL_OBJS) PREFIX_OBJS = $(PREFIX_REAL_OBJS)
LIBRARY_VERSION := $(LIB_VERSION) LIBRARY_VERSION := $(LIB_VERSION)
...@@ -1010,6 +1021,7 @@ ifeq ($(strip $(filter-out lynxos,$(osys))),) ...@@ -1010,6 +1021,7 @@ ifeq ($(strip $(filter-out lynxos,$(osys))),)
a-numaux.adb<a-numaux-x86.adb \ a-numaux.adb<a-numaux-x86.adb \
a-numaux.ads<a-numaux-x86.ads \ a-numaux.ads<a-numaux-x86.ads \
a-intnam.ads<a-intnam-lynxos.ads \ a-intnam.ads<a-intnam-lynxos.ads \
g-bytswa.adb<g-bytswa-x86.adb \
s-inmaop.adb<s-inmaop-posix.adb \ s-inmaop.adb<s-inmaop-posix.adb \
s-intman.adb<s-intman-posix.adb \ s-intman.adb<s-intman-posix.adb \
s-osinte.adb<s-osinte-lynxos.adb \ s-osinte.adb<s-osinte-lynxos.adb \
...@@ -1142,6 +1154,7 @@ endif ...@@ -1142,6 +1154,7 @@ endif
g-soccon.ads<g-soccon-vms.ads \ g-soccon.ads<g-soccon-vms.ads \
g-socthi.ads<g-socthi-vms.ads \ g-socthi.ads<g-socthi-vms.ads \
g-socthi.adb<g-socthi-vms.adb \ g-socthi.adb<g-socthi-vms.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
i-c.ads<i-c-vms_64.ads \ i-c.ads<i-c-vms_64.ads \
i-cstrin.ads<i-cstrin-vms_64.ads \ i-cstrin.ads<i-cstrin-vms_64.ads \
i-cstrin.adb<i-cstrin-vms_64.adb \ i-cstrin.adb<i-cstrin-vms_64.adb \
...@@ -1212,8 +1225,10 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),) ...@@ -1212,8 +1225,10 @@ ifeq ($(strip $(filter-out cygwin32% mingw32% pe,$(osys))),)
s-osprim.adb<s-osprim-mingw.adb \ s-osprim.adb<s-osprim-mingw.adb \
s-taprop.adb<s-taprop-mingw.adb \ s-taprop.adb<s-taprop-mingw.adb \
s-taspri.ads<s-taspri-mingw.ads \ s-taspri.ads<s-taspri-mingw.ads \
g-bytswa.adb<g-bytswa-x86.adb \
g-socthi.ads<g-socthi-mingw.ads \ g-socthi.ads<g-socthi-mingw.ads \
g-socthi.adb<g-socthi-mingw.adb \ g-socthi.adb<g-socthi-mingw.adb \
g-stsifd.adb<g-stsifd-sockets.adb \
g-soccon.ads<g-soccon-mingw.ads \ g-soccon.ads<g-soccon-mingw.ads \
g-soliop.ads<g-soliop-mingw.ads \ g-soliop.ads<g-soliop-mingw.ads \
system.ads<system-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 ...@@ -236,14 +236,13 @@ package body GNAT.Sockets is
-------------------- --------------------
procedure Abort_Selector (Selector : Selector_Type) is procedure Abort_Selector (Selector : Selector_Type) is
Buf : aliased Character := ASCII.NUL;
Res : C.int; Res : C.int;
begin 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 if Res = Failure then
Raise_Socket_Error (Socket_Errno); Raise_Socket_Error (Socket_Errno);
end if; end if;
...@@ -454,16 +453,11 @@ package body GNAT.Sockets is ...@@ -454,16 +453,11 @@ package body GNAT.Sockets is
if Is_Set (RSet, RSig) then if Is_Set (RSet, RSig) then
Clear (RSet, RSig); Clear (RSet, RSig);
declare Res := Signalling_Fds.Read (C.int (RSig));
Buf : Character;
begin
Res := C_Recv (C.int (RSig), Buf'Address, 1, 0);
if Res = Failure then if Res = Failure then
Raise_Socket_Error (Socket_Errno); Raise_Socket_Error (Socket_Errno);
end if; end if;
end;
Status := Aborted; Status := Aborted;
...@@ -674,105 +668,23 @@ package body GNAT.Sockets is ...@@ -674,105 +668,23 @@ package body GNAT.Sockets is
--------------------- ---------------------
procedure Create_Selector (Selector : out Selector_Type) is procedure Create_Selector (Selector : out Selector_Type) is
S0 : C.int; Two_Fds : aliased Fd_Pair;
S1 : C.int; Res : C.int;
S2 : C.int;
Res : C.int;
Sin : aliased Sockaddr_In;
Len : aliased C.int := Sin'Size / 8;
Err : Integer;
begin begin
-- We open two signalling sockets. One of them is used to send data to -- We open two signalling file descriptors. One of them is used to send
-- the other, which is included in a C_Select socket set. The -- 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 -- communication is used to force a call to C_Select to complete, and
-- the waiting task to resume its execution. -- the waiting task to resume its execution.
-- Create a listening socket Res := Signalling_Fds.Create (Two_Fds'Access);
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);
if Res = Failure then if Res = Failure then
Raise_Socket_Error (Socket_Errno); Raise_Socket_Error (Socket_Errno);
end if; end if;
Selector.R_Sig_Socket := Socket_Type (S1); Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End));
Selector.W_Sig_Socket := Socket_Type (S2); Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End));
end Create_Selector; end Create_Selector;
------------------- -------------------
...@@ -1073,7 +985,7 @@ package body GNAT.Sockets is ...@@ -1073,7 +985,7 @@ package body GNAT.Sockets is
is is
use type C.unsigned_char; use type C.unsigned_char;
V8 : aliased Two_Int; V8 : aliased Two_Ints;
V4 : aliased C.int; V4 : aliased C.int;
V1 : aliased C.unsigned_char; V1 : aliased C.unsigned_char;
VT : aliased Timeval; VT : aliased Timeval;
...@@ -1899,7 +1811,7 @@ package body GNAT.Sockets is ...@@ -1899,7 +1811,7 @@ package body GNAT.Sockets is
Level : Level_Type := Socket_Level; Level : Level_Type := Socket_Level;
Option : Option_Type) Option : Option_Type)
is is
V8 : aliased Two_Int; V8 : aliased Two_Ints;
V4 : aliased C.int; V4 : aliased C.int;
V1 : aliased C.unsigned_char; V1 : aliased C.unsigned_char;
VT : aliased Timeval; VT : aliased Timeval;
......
gcc/ada/g-socthi-mingw.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -48,13 +48,13 @@ package body GNAT.Sockets.Thin is ...@@ -48,13 +48,13 @@ package body GNAT.Sockets.Thin is
WSAData_Dummy : array (1 .. 512) of C.int; WSAData_Dummy : array (1 .. 512) of C.int;
WS_Version : constant := 16#0101#; WS_Version : constant := 16#0202#;
Initialized : Boolean := False; Initialized : Boolean := False;
SYSNOTREADY : constant := 10091; SYSNOTREADY : constant := 10091;
VERNOTSUPPORTED : constant := 10092; VERNOTSUPPORTED : constant := 10092;
NOTINITIALISED : constant := 10093; NOTINITIALISED : constant := 10093;
EDISCON : constant := 10101; EDISCON : constant := 10101;
function Standard_Connect function Standard_Connect
(S : C.int; (S : C.int;
...@@ -258,11 +258,11 @@ package body GNAT.Sockets.Thin is ...@@ -258,11 +258,11 @@ package body GNAT.Sockets.Thin is
------------- -------------
function C_Readv function C_Readv
(Socket : C.int; (Fd : C.int;
Iov : System.Address; Iov : System.Address;
Iovcnt : C.int) return C.int Iovcnt : C.int) return C.int
is is
Res : C.int; Res : C.int;
Count : C.int := 0; Count : C.int := 0;
Iovec : array (0 .. Iovcnt - 1) of Vector_Element; Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
...@@ -272,7 +272,7 @@ package body GNAT.Sockets.Thin is ...@@ -272,7 +272,7 @@ package body GNAT.Sockets.Thin is
begin begin
for J in Iovec'Range loop for J in Iovec'Range loop
Res := C_Recv Res := C_Recv
(Socket, (Fd,
Iovec (J).Base.all'Address, Iovec (J).Base.all'Address,
C.int (Iovec (J).Length), C.int (Iovec (J).Length),
0); 0);
...@@ -434,11 +434,11 @@ package body GNAT.Sockets.Thin is ...@@ -434,11 +434,11 @@ package body GNAT.Sockets.Thin is
-------------- --------------
function C_Writev function C_Writev
(Socket : C.int; (Fd : C.int;
Iov : System.Address; Iov : System.Address;
Iovcnt : C.int) return C.int Iovcnt : C.int) return C.int
is is
Res : C.int; Res : C.int;
Count : C.int := 0; Count : C.int := 0;
Iovec : array (0 .. Iovcnt - 1) of Vector_Element; Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
...@@ -448,7 +448,7 @@ package body GNAT.Sockets.Thin is ...@@ -448,7 +448,7 @@ package body GNAT.Sockets.Thin is
begin begin
for J in Iovec'Range loop for J in Iovec'Range loop
Res := C_Send Res := C_Send
(Socket, (Fd,
Iovec (J).Base.all'Address, Iovec (J).Base.all'Address,
C.int (Iovec (J).Length), C.int (Iovec (J).Length),
0); 0);
...@@ -478,7 +478,7 @@ package body GNAT.Sockets.Thin is ...@@ -478,7 +478,7 @@ package body GNAT.Sockets.Thin is
-- Initialize -- -- Initialize --
---------------- ----------------
procedure Initialize (Process_Blocking_IO : Boolean := False) is procedure Initialize (Process_Blocking_IO : Boolean) is
pragma Unreferenced (Process_Blocking_IO); pragma Unreferenced (Process_Blocking_IO);
Return_Value : Interfaces.C.int; Return_Value : Interfaces.C.int;
...@@ -542,6 +542,12 @@ package body GNAT.Sockets.Thin is ...@@ -542,6 +542,12 @@ package body GNAT.Sockets.Thin is
Sin.Sin_Port := Port; Sin.Sin_Port := Port;
end Set_Port; end Set_Port;
--------------------
-- Signalling_Fds --
--------------------
package body Signalling_Fds is separate;
-------------------------- --------------------------
-- Socket_Error_Message -- -- Socket_Error_Message --
-------------------------- --------------------------
......
gcc/ada/g-socthi-mingw.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -60,10 +60,9 @@ package GNAT.Sockets.Thin is ...@@ -60,10 +60,9 @@ package GNAT.Sockets.Thin is
procedure Set_Socket_Errno (Errno : Integer); procedure Set_Socket_Errno (Errno : Integer);
-- Set last socket error number -- Set last socket error number
function Socket_Error_Message function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
(Errno : Integer) return C.Strings.chars_ptr; -- Returns the error message string for the error number Errno. If Errno is
-- Returns the error message string for the error number Errno. If -- not known it returns "Unknown system error".
-- Errno is not known it returns "Unknown system error".
function Host_Errno return Integer; function Host_Errno return Integer;
pragma Import (C, Host_Errno, "__gnat_get_h_errno"); pragma Import (C, Host_Errno, "__gnat_get_h_errno");
...@@ -73,14 +72,14 @@ package GNAT.Sockets.Thin is ...@@ -73,14 +72,14 @@ package GNAT.Sockets.Thin is
No_Fd_Set : constant Fd_Set_Access := System.Null_Address; No_Fd_Set : constant Fd_Set_Access := System.Null_Address;
type time_t is 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; .. 2 ** (8 * Constants.SIZEOF_tv_sec - 1) - 1;
for time_t'Size use 8 * Constants.SIZEOF_tv_sec; for time_t'Size use 8 * Constants.SIZEOF_tv_sec;
pragma Convention (C, time_t); pragma Convention (C, time_t);
type suseconds_t is 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; .. 2 ** (8 * Constants.SIZEOF_tv_usec - 1) - 1;
for suseconds_t'Size use 8 * Constants.SIZEOF_tv_usec; for suseconds_t'Size use 8 * Constants.SIZEOF_tv_usec;
pragma Convention (C, suseconds_t); pragma Convention (C, suseconds_t);
...@@ -104,7 +103,7 @@ package GNAT.Sockets.Thin is ...@@ -104,7 +103,7 @@ package GNAT.Sockets.Thin is
package Chars_Ptr_Pointers is package Chars_Ptr_Pointers is
new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array, new C.Pointers (C.size_t, C.Strings.chars_ptr, Chars_Ptr_Array,
C.Strings.Null_Ptr); C.Strings.Null_Ptr);
-- Arrays of C (char *) -- Arrays of C (char *)
type In_Addr is record type In_Addr is record
...@@ -123,6 +122,7 @@ package GNAT.Sockets.Thin is ...@@ -123,6 +122,7 @@ package GNAT.Sockets.Thin is
type In_Addr_Access_Array is array (C.size_t range <>) type In_Addr_Access_Array is array (C.size_t range <>)
of aliased In_Addr_Access; of aliased In_Addr_Access;
pragma Convention (C, In_Addr_Access_Array); pragma Convention (C, In_Addr_Access_Array);
package In_Addr_Access_Pointers is package In_Addr_Access_Pointers is
new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null); new C.Pointers (C.size_t, In_Addr_Access, In_Addr_Access_Array, null);
-- Array of internet addresses -- Array of internet addresses
...@@ -203,14 +203,24 @@ package GNAT.Sockets.Thin is ...@@ -203,14 +203,24 @@ package GNAT.Sockets.Thin is
pragma Convention (C, Servent_Access); pragma Convention (C, Servent_Access);
-- Access to service entry -- Access to service entry
type Two_Int is array (0 .. 1) of C.int; type Two_Ints is array (0 .. 1) of C.int;
pragma Convention (C, Two_Int); pragma Convention (C, Two_Ints);
-- Used with pipe() -- 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 function C_Accept
(S : C.int; (S : C.int;
Addr : System.Address; Addr : System.Address;
Addrlen : access C.int) return C.int; Addrlen : not null access C.int) return C.int;
function C_Bind function C_Bind
(S : C.int; (S : C.int;
...@@ -226,9 +236,9 @@ package GNAT.Sockets.Thin is ...@@ -226,9 +236,9 @@ package GNAT.Sockets.Thin is
Namelen : C.int) return C.int; Namelen : C.int) return C.int;
function C_Gethostbyaddr function C_Gethostbyaddr
(Addr : System.Address; (Addr : System.Address;
Length : C.int; Len : C.int;
Typ : C.int) return Hostent_Access; Typ : C.int) return Hostent_Access;
function C_Gethostbyname function C_Gethostbyname
(Name : C.char_array) return Hostent_Access; (Name : C.char_array) return Hostent_Access;
...@@ -240,7 +250,7 @@ package GNAT.Sockets.Thin is ...@@ -240,7 +250,7 @@ package GNAT.Sockets.Thin is
function C_Getpeername function C_Getpeername
(S : C.int; (S : C.int;
Name : System.Address; Name : System.Address;
Namelen : access C.int) return C.int; Namelen : not null access C.int) return C.int;
function C_Getservbyname function C_Getservbyname
(Name : C.char_array; (Name : C.char_array;
...@@ -253,14 +263,14 @@ package GNAT.Sockets.Thin is ...@@ -253,14 +263,14 @@ package GNAT.Sockets.Thin is
function C_Getsockname function C_Getsockname
(S : C.int; (S : C.int;
Name : System.Address; Name : System.Address;
Namelen : access C.int) return C.int; Namelen : not null access C.int) return C.int;
function C_Getsockopt function C_Getsockopt
(S : C.int; (S : C.int;
Level : C.int; Level : C.int;
Optname : C.int; Optname : C.int;
Optval : System.Address; Optval : System.Address;
Optlen : access C.int) return C.int; Optlen : not null access C.int) return C.int;
function C_Inet_Addr function C_Inet_Addr
(Cp : C.Strings.chars_ptr) return C.int; (Cp : C.Strings.chars_ptr) return C.int;
...@@ -275,23 +285,23 @@ package GNAT.Sockets.Thin is ...@@ -275,23 +285,23 @@ package GNAT.Sockets.Thin is
Backlog : C.int) return C.int; Backlog : C.int) return C.int;
function C_Readv function C_Readv
(Socket : C.int; (Fd : C.int;
Iov : System.Address; Iov : System.Address;
Iovcnt : C.int) return C.int; Iovcnt : C.int) return C.int;
function C_Recv function C_Recv
(S : C.int; (S : C.int;
Buf : System.Address; Msg : System.Address;
Len : C.int; Len : C.int;
Flags : C.int) return C.int; Flags : C.int) return C.int;
function C_Recvfrom function C_Recvfrom
(S : C.int; (S : C.int;
Buf : System.Address; Msg : System.Address;
Len : C.int; Len : C.int;
Flags : C.int; Flags : C.int;
From : Sockaddr_In_Access; From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int; Fromlen : not null access C.int) return C.int;
function C_Select function C_Select
(Nfds : C.int; (Nfds : C.int;
...@@ -302,7 +312,7 @@ package GNAT.Sockets.Thin is ...@@ -302,7 +312,7 @@ package GNAT.Sockets.Thin is
function C_Send function C_Send
(S : C.int; (S : C.int;
Buf : System.Address; Msg : System.Address;
Len : C.int; Len : C.int;
Flags : C.int) return C.int; Flags : C.int) return C.int;
...@@ -322,8 +332,8 @@ package GNAT.Sockets.Thin is ...@@ -322,8 +332,8 @@ package GNAT.Sockets.Thin is
Optlen : C.int) return C.int; Optlen : C.int) return C.int;
function C_Shutdown function C_Shutdown
(S : C.int; (S : C.int;
How : C.int) return C.int; How : C.int) return C.int;
function C_Socket function C_Socket
(Domain : C.int; (Domain : C.int;
...@@ -337,7 +347,7 @@ package GNAT.Sockets.Thin is ...@@ -337,7 +347,7 @@ package GNAT.Sockets.Thin is
(Command : System.Address) return C.int; (Command : System.Address) return C.int;
function C_Writev function C_Writev
(Socket : C.int; (Fd : C.int;
Iov : System.Address; Iov : System.Address;
Iovcnt : C.int) return C.int; Iovcnt : C.int) return C.int;
...@@ -345,6 +355,25 @@ package GNAT.Sockets.Thin is ...@@ -345,6 +355,25 @@ package GNAT.Sockets.Thin is
(WS_Version : Interfaces.C.int; (WS_Version : Interfaces.C.int;
WSADataAddress : System.Address) return 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 procedure Free_Socket_Set
(Set : Fd_Set_Access); (Set : Fd_Set_Access);
-- Free system-dependent socket set -- Free system-dependent socket set
...@@ -371,19 +400,19 @@ package GNAT.Sockets.Thin is ...@@ -371,19 +400,19 @@ package GNAT.Sockets.Thin is
-- value if it is, zero if it is not. -- value if it is, zero if it is not.
procedure Last_Socket_In_Set procedure Last_Socket_In_Set
(Set : Fd_Set_Access; (Set : Fd_Set_Access;
Last : Int_Access); Last : Int_Access);
-- Find the largest socket in the socket set. This is needed for -- Find the largest socket in the socket set. This is needed for select().
-- select(). When Last_Socket_In_Set is called, parameter Last is -- When Last_Socket_In_Set is called, parameter Last is a maximum value of
-- a maximum value of the largest socket. This hint is used to -- the largest socket. This hint is used to avoid scanning very large
-- avoid scanning very large socket sets. After the call, Last is -- socket sets. After the call, Last is set back to the real largest socket
-- set back to the real largest socket in the socket set. -- in the socket set.
function New_Socket_Set function New_Socket_Set
(Set : Fd_Set_Access) return Fd_Set_Access; (Set : Fd_Set_Access) return Fd_Set_Access;
-- Allocate a new socket set which is a system-dependent structure -- Allocate a new socket set which is a system-dependent structure and
-- and initialize by copying Set if it is non-null, by making it -- initialize by copying Set if it is non-null, by making it empty
-- empty otherwise. -- otherwise.
procedure Remove_Socket_From_Set procedure Remove_Socket_From_Set
(Set : Fd_Set_Access; (Set : Fd_Set_Access;
...@@ -393,7 +422,7 @@ package GNAT.Sockets.Thin is ...@@ -393,7 +422,7 @@ package GNAT.Sockets.Thin is
procedure WSACleanup; procedure WSACleanup;
procedure Finalize; procedure Finalize;
procedure Initialize (Process_Blocking_IO : Boolean := False); procedure Initialize (Process_Blocking_IO : Boolean);
private private
pragma Import (Stdcall, C_Accept, "accept"); pragma Import (Stdcall, C_Accept, "accept");
...@@ -430,4 +459,5 @@ private ...@@ -430,4 +459,5 @@ private
pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); 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, Insert_Socket_In_Set, "__gnat_insert_socket_in_set");
pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set");
end GNAT.Sockets.Thin; end GNAT.Sockets.Thin;
gcc/ada/g-socthi-vms.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -64,7 +64,7 @@ package body GNAT.Sockets.Thin is ...@@ -64,7 +64,7 @@ package body GNAT.Sockets.Thin is
function Syscall_Accept function Syscall_Accept
(S : C.int; (S : C.int;
Addr : System.Address; 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"); pragma Import (C, Syscall_Accept, "accept");
function Syscall_Connect function Syscall_Connect
...@@ -92,7 +92,7 @@ package body GNAT.Sockets.Thin is ...@@ -92,7 +92,7 @@ package body GNAT.Sockets.Thin is
Len : C.int; Len : C.int;
Flags : C.int; Flags : C.int;
From : Sockaddr_In_Access; 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"); pragma Import (C, Syscall_Recvfrom, "recvfrom");
function Syscall_Send function Syscall_Send
...@@ -125,7 +125,7 @@ package body GNAT.Sockets.Thin is ...@@ -125,7 +125,7 @@ package body GNAT.Sockets.Thin is
function C_Accept function C_Accept
(S : C.int; (S : C.int;
Addr : System.Address; Addr : System.Address;
Addrlen : access C.int) return C.int Addrlen : not null access C.int) return C.int
is is
R : C.int; R : C.int;
Val : aliased C.int := 1; Val : aliased C.int := 1;
...@@ -275,7 +275,7 @@ package body GNAT.Sockets.Thin is ...@@ -275,7 +275,7 @@ package body GNAT.Sockets.Thin is
Len : C.int; Len : C.int;
Flags : C.int; Flags : C.int;
From : Sockaddr_In_Access; From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int Fromlen : not null access C.int) return C.int
is is
Res : C.int; Res : C.int;
...@@ -461,6 +461,12 @@ package body GNAT.Sockets.Thin is ...@@ -461,6 +461,12 @@ package body GNAT.Sockets.Thin is
Sin.Sin_Port := Port; Sin.Sin_Port := Port;
end Set_Port; end Set_Port;
--------------------
-- Signalling_Fds --
--------------------
package body Signalling_Fds is separate;
-------------------------- --------------------------
-- Socket_Error_Message -- -- Socket_Error_Message --
-------------------------- --------------------------
......
gcc/ada/g-socthi-vms.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -38,8 +38,8 @@ ...@@ -38,8 +38,8 @@
-- This is the Alpha/VMS version -- This is the Alpha/VMS version
with Interfaces.C.Pointers; with Interfaces.C.Pointers;
with Interfaces.C.Strings; with Interfaces.C.Strings;
with GNAT.Sockets.Constants; with GNAT.Sockets.Constants;
with GNAT.OS_Lib; with GNAT.OS_Lib;
...@@ -60,9 +60,12 @@ package GNAT.Sockets.Thin is ...@@ -60,9 +60,12 @@ package GNAT.Sockets.Thin is
function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
-- Returns last socket error number -- 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; function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
-- Returns the error message string for the error number Errno. If -- Returns the error message string for the error number Errno. If Errno is
-- Errno is not known it returns "Unknown system error". -- not known it returns "Unknown system error".
function Host_Errno return Integer; function Host_Errno return Integer;
pragma Import (C, Host_Errno, "__gnat_get_h_errno"); pragma Import (C, Host_Errno, "__gnat_get_h_errno");
...@@ -165,8 +168,8 @@ package GNAT.Sockets.Thin is ...@@ -165,8 +168,8 @@ package GNAT.Sockets.Thin is
-- Set Sin.Sin_Family to Family -- Set Sin.Sin_Family to Family
procedure Set_Port procedure Set_Port
(Sin : Sockaddr_In_Access; (Sin : Sockaddr_In_Access;
Port : C.unsigned_short); Port : C.unsigned_short);
pragma Inline (Set_Port); pragma Inline (Set_Port);
-- Set Sin.Sin_Port to Port -- Set Sin.Sin_Port to Port
...@@ -203,14 +206,24 @@ package GNAT.Sockets.Thin is ...@@ -203,14 +206,24 @@ package GNAT.Sockets.Thin is
pragma Convention (C, Servent_Access); pragma Convention (C, Servent_Access);
-- Access to service entry -- Access to service entry
type Two_Int is array (0 .. 1) of C.int; type Two_Ints is array (0 .. 1) of C.int;
pragma Convention (C, Two_Int); pragma Convention (C, Two_Ints);
-- Used with pipe() -- 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 function C_Accept
(S : C.int; (S : C.int;
Addr : System.Address; Addr : System.Address;
Addrlen : access C.int) return C.int; Addrlen : not null access C.int) return C.int;
function C_Bind function C_Bind
(S : C.int; (S : C.int;
...@@ -240,7 +253,7 @@ package GNAT.Sockets.Thin is ...@@ -240,7 +253,7 @@ package GNAT.Sockets.Thin is
function C_Getpeername function C_Getpeername
(S : C.int; (S : C.int;
Name : System.Address; Name : System.Address;
Namelen : access C.int) return C.int; Namelen : not null access C.int) return C.int;
function C_Getservbyname function C_Getservbyname
(Name : C.char_array; (Name : C.char_array;
...@@ -253,24 +266,26 @@ package GNAT.Sockets.Thin is ...@@ -253,24 +266,26 @@ package GNAT.Sockets.Thin is
function C_Getsockname function C_Getsockname
(S : C.int; (S : C.int;
Name : System.Address; Name : System.Address;
Namelen : access C.int) return C.int; Namelen : not null access C.int) return C.int;
function C_Getsockopt function C_Getsockopt
(S : C.int; (S : C.int;
Level : C.int; Level : C.int;
Optname : C.int; Optname : C.int;
Optval : System.Address; Optval : System.Address;
Optlen : access C.int) return C.int; Optlen : not null access C.int) return C.int;
function C_Inet_Addr function C_Inet_Addr
(Cp : C.Strings.chars_ptr) return C.int; (Cp : C.Strings.chars_ptr) return C.int;
function C_Ioctl function C_Ioctl
(S : C.int; (S : C.int;
Req : C.int; Req : C.int;
Arg : Int_Access) return 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 function C_Readv
(Fd : C.int; (Fd : C.int;
...@@ -289,7 +304,7 @@ package GNAT.Sockets.Thin is ...@@ -289,7 +304,7 @@ package GNAT.Sockets.Thin is
Len : C.int; Len : C.int;
Flags : C.int; Flags : C.int;
From : Sockaddr_In_Access; From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int; Fromlen : not null access C.int) return C.int;
function C_Select function C_Select
(Nfds : C.int; (Nfds : C.int;
...@@ -320,8 +335,8 @@ package GNAT.Sockets.Thin is ...@@ -320,8 +335,8 @@ package GNAT.Sockets.Thin is
Optlen : C.int) return C.int; Optlen : C.int) return C.int;
function C_Shutdown function C_Shutdown
(S : C.int; (S : C.int;
How : C.int) return C.int; How : C.int) return C.int;
function C_Socket function C_Socket
(Domain : C.int; (Domain : C.int;
...@@ -339,6 +354,25 @@ package GNAT.Sockets.Thin is ...@@ -339,6 +354,25 @@ package GNAT.Sockets.Thin is
Iov : System.Address; Iov : System.Address;
Iovcnt : C.int) return C.int; 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 procedure Free_Socket_Set
(Set : Fd_Set_Access); (Set : Fd_Set_Access);
-- Free system-dependent socket set -- Free system-dependent socket set
...@@ -367,17 +401,17 @@ package GNAT.Sockets.Thin is ...@@ -367,17 +401,17 @@ package GNAT.Sockets.Thin is
procedure Last_Socket_In_Set procedure Last_Socket_In_Set
(Set : Fd_Set_Access; (Set : Fd_Set_Access;
Last : Int_Access); Last : Int_Access);
-- Find the largest socket in the socket set. This is needed for -- Find the largest socket in the socket set. This is needed for select().
-- select(). When Last_Socket_In_Set is called, parameter Last is -- When Last_Socket_In_Set is called, parameter Last is a maximum value of
-- a maximum value of the largest socket. This hint is used to -- the largest socket. This hint is used to avoid scanning very large
-- avoid scanning very large socket sets. After the call, Last is -- socket sets. After the call, Last is set back to the real largest socket
-- set back to the real largest socket in the socket set. -- in the socket set.
function New_Socket_Set function New_Socket_Set
(Set : Fd_Set_Access) return Fd_Set_Access; (Set : Fd_Set_Access) return Fd_Set_Access;
-- Allocate a new socket set which is a system-dependent structure -- Allocate a new socket set which is a system-dependent structure and
-- and initialize by copying Set if it is non-null, by making it -- initialize by copying Set if it is non-null, by making it empty
-- empty otherwise. -- otherwise.
procedure Remove_Socket_From_Set procedure Remove_Socket_From_Set
(Set : Fd_Set_Access; (Set : Fd_Set_Access;
...@@ -414,4 +448,5 @@ private ...@@ -414,4 +448,5 @@ private
pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); 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, Insert_Socket_In_Set, "__gnat_insert_socket_in_set");
pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set");
end GNAT.Sockets.Thin; end GNAT.Sockets.Thin;
gcc/ada/g-socthi-vxworks.adb
...@@ -92,7 +92,7 @@ package body GNAT.Sockets.Thin is ...@@ -92,7 +92,7 @@ package body GNAT.Sockets.Thin is
function Syscall_Accept function Syscall_Accept
(S : C.int; (S : C.int;
Addr : System.Address; 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"); pragma Import (C, Syscall_Accept, "accept");
function Syscall_Connect function Syscall_Connect
...@@ -120,7 +120,7 @@ package body GNAT.Sockets.Thin is ...@@ -120,7 +120,7 @@ package body GNAT.Sockets.Thin is
Len : C.int; Len : C.int;
Flags : C.int; Flags : C.int;
From : Sockaddr_In_Access; 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"); pragma Import (C, Syscall_Recvfrom, "recvfrom");
function Syscall_Send function Syscall_Send
...@@ -155,7 +155,7 @@ package body GNAT.Sockets.Thin is ...@@ -155,7 +155,7 @@ package body GNAT.Sockets.Thin is
function C_Accept function C_Accept
(S : C.int; (S : C.int;
Addr : System.Address; Addr : System.Address;
Addrlen : access C.int) return C.int Addrlen : not null access C.int) return C.int
is is
R : C.int; R : C.int;
Val : aliased C.int := 1; Val : aliased C.int := 1;
...@@ -398,7 +398,7 @@ package body GNAT.Sockets.Thin is ...@@ -398,7 +398,7 @@ package body GNAT.Sockets.Thin is
Len : C.int; Len : C.int;
Flags : C.int; Flags : C.int;
From : Sockaddr_In_Access; From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int Fromlen : not null access C.int) return C.int
is is
Res : C.int; Res : C.int;
...@@ -594,6 +594,12 @@ package body GNAT.Sockets.Thin is ...@@ -594,6 +594,12 @@ package body GNAT.Sockets.Thin is
Sin.Sin_Port := Port; Sin.Sin_Port := Port;
end Set_Port; end Set_Port;
--------------------
-- Signalling_Fds --
--------------------
package body Signalling_Fds is separate;
-------------------------- --------------------------
-- Socket_Error_Message -- -- Socket_Error_Message --
-------------------------- --------------------------
......
gcc/ada/g-socthi-vxworks.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -38,9 +38,10 @@ ...@@ -38,9 +38,10 @@
-- This is the version for VxWorks -- This is the version for VxWorks
with Interfaces.C.Pointers; with Interfaces.C.Pointers;
with Interfaces.C.Strings;
with Ada.Unchecked_Conversion; with Ada.Unchecked_Conversion;
with Interfaces.C.Strings;
with GNAT.Sockets.Constants; with GNAT.Sockets.Constants;
with GNAT.OS_Lib; with GNAT.OS_Lib;
...@@ -59,6 +60,9 @@ package GNAT.Sockets.Thin is ...@@ -59,6 +60,9 @@ package GNAT.Sockets.Thin is
function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
-- Returns last socket error number -- 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; function Socket_Error_Message (Errno : Integer) return C.Strings.chars_ptr;
-- Returns the error message string for the error number Errno. If Errno is -- Returns the error message string for the error number Errno. If Errno is
-- not known it returns "Unknown system error". -- not known it returns "Unknown system error".
...@@ -161,20 +165,20 @@ package GNAT.Sockets.Thin is ...@@ -161,20 +165,20 @@ package GNAT.Sockets.Thin is
-- Set Sin.Sin_Length to Len -- Set Sin.Sin_Length to Len
procedure Set_Family procedure Set_Family
(Sin : Sockaddr_In_Access; (Sin : Sockaddr_In_Access;
Family : C.int); Family : C.int);
pragma Inline (Set_Family); pragma Inline (Set_Family);
-- Set Sin.Sin_Family to Family -- Set Sin.Sin_Family to Family
procedure Set_Port procedure Set_Port
(Sin : Sockaddr_In_Access; (Sin : Sockaddr_In_Access;
Port : C.unsigned_short); Port : C.unsigned_short);
pragma Inline (Set_Port); pragma Inline (Set_Port);
-- Set Sin.Sin_Port to Port -- Set Sin.Sin_Port to Port
procedure Set_Address procedure Set_Address
(Sin : Sockaddr_In_Access; (Sin : Sockaddr_In_Access;
Address : In_Addr); Address : In_Addr);
pragma Inline (Set_Address); pragma Inline (Set_Address);
-- Set Sin.Sin_Addr to Address -- Set Sin.Sin_Addr to Address
...@@ -193,10 +197,10 @@ package GNAT.Sockets.Thin is ...@@ -193,10 +197,10 @@ package GNAT.Sockets.Thin is
-- Access to host entry -- Access to host entry
type Servent is record type Servent is record
S_Name : C.Strings.chars_ptr; S_Name : C.Strings.chars_ptr;
S_Aliases : Chars_Ptr_Pointers.Pointer; S_Aliases : Chars_Ptr_Pointers.Pointer;
S_Port : C.int; S_Port : C.int;
S_Proto : C.Strings.chars_ptr; S_Proto : C.Strings.chars_ptr;
end record; end record;
pragma Convention (C, Servent); pragma Convention (C, Servent);
-- Service entry -- Service entry
...@@ -205,14 +209,24 @@ package GNAT.Sockets.Thin is ...@@ -205,14 +209,24 @@ package GNAT.Sockets.Thin is
pragma Convention (C, Servent_Access); pragma Convention (C, Servent_Access);
-- Access to service entry -- Access to service entry
type Two_Int is array (0 .. 1) of C.int; type Two_Ints is array (0 .. 1) of C.int;
pragma Convention (C, Two_Int); pragma Convention (C, Two_Ints);
-- Used with pipe() -- 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 function C_Accept
(S : C.int; (S : C.int;
Addr : System.Address; Addr : System.Address;
Addrlen : access C.int) return C.int; Addrlen : not null access C.int) return C.int;
function C_Bind function C_Bind
(S : C.int; (S : C.int;
...@@ -242,7 +256,7 @@ package GNAT.Sockets.Thin is ...@@ -242,7 +256,7 @@ package GNAT.Sockets.Thin is
function C_Getpeername function C_Getpeername
(S : C.int; (S : C.int;
Name : System.Address; Name : System.Address;
Namelen : access C.int) return C.int; Namelen : not null access C.int) return C.int;
function C_Getservbyname function C_Getservbyname
(Name : C.char_array; (Name : C.char_array;
...@@ -255,24 +269,26 @@ package GNAT.Sockets.Thin is ...@@ -255,24 +269,26 @@ package GNAT.Sockets.Thin is
function C_Getsockname function C_Getsockname
(S : C.int; (S : C.int;
Name : System.Address; Name : System.Address;
Namelen : access C.int) return C.int; Namelen : not null access C.int) return C.int;
function C_Getsockopt function C_Getsockopt
(S : C.int; (S : C.int;
Level : C.int; Level : C.int;
Optname : C.int; Optname : C.int;
Optval : System.Address; Optval : System.Address;
Optlen : access C.int) return C.int; Optlen : not null access C.int) return C.int;
function C_Inet_Addr function C_Inet_Addr
(Cp : C.Strings.chars_ptr) return C.int; (Cp : C.Strings.chars_ptr) return C.int;
function C_Ioctl function C_Ioctl
(S : C.int; (S : C.int;
Req : C.int; Req : C.int;
Arg : Int_Access) return 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 function C_Readv
(Fd : C.int; (Fd : C.int;
...@@ -291,7 +307,7 @@ package GNAT.Sockets.Thin is ...@@ -291,7 +307,7 @@ package GNAT.Sockets.Thin is
Len : C.int; Len : C.int;
Flags : C.int; Flags : C.int;
From : Sockaddr_In_Access; From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int; Fromlen : not null access C.int) return C.int;
function C_Select function C_Select
(Nfds : C.int; (Nfds : C.int;
...@@ -341,6 +357,25 @@ package GNAT.Sockets.Thin is ...@@ -341,6 +357,25 @@ package GNAT.Sockets.Thin is
Iov : System.Address; Iov : System.Address;
Iovcnt : C.int) return C.int; 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 procedure Free_Socket_Set
(Set : Fd_Set_Access); (Set : Fd_Set_Access);
-- Free system-dependent socket set -- Free system-dependent socket set
...@@ -369,17 +404,17 @@ package GNAT.Sockets.Thin is ...@@ -369,17 +404,17 @@ package GNAT.Sockets.Thin is
procedure Last_Socket_In_Set procedure Last_Socket_In_Set
(Set : Fd_Set_Access; (Set : Fd_Set_Access;
Last : Int_Access); Last : Int_Access);
-- Find the largest socket in the socket set. This is needed for -- Find the largest socket in the socket set. This is needed for select().
-- select(). When Last_Socket_In_Set is called, parameter Last is -- When Last_Socket_In_Set is called, parameter Last is a maximum value of
-- a maximum value of the largest socket. This hint is used to -- the largest socket. This hint is used to avoid scanning very large
-- avoid scanning very large socket sets. After the call, Last is -- socket sets. After the call, Last is set back to the real largest socket
-- set back to the real largest socket in the socket set. -- in the socket set.
function New_Socket_Set function New_Socket_Set
(Set : Fd_Set_Access) return Fd_Set_Access; (Set : Fd_Set_Access) return Fd_Set_Access;
-- Allocate a new socket set which is a system-dependent structure -- Allocate a new socket set which is a system-dependent structure and
-- and initialize by copying Set if it is non-null, by making it -- initialize by copying Set if it is non-null, by making it empty
-- empty otherwise. -- otherwise.
procedure Remove_Socket_From_Set procedure Remove_Socket_From_Set
(Set : Fd_Set_Access; (Set : Fd_Set_Access;
...@@ -390,7 +425,6 @@ package GNAT.Sockets.Thin is ...@@ -390,7 +425,6 @@ package GNAT.Sockets.Thin is
procedure Initialize (Process_Blocking_IO : Boolean); procedure Initialize (Process_Blocking_IO : Boolean);
private private
pragma Import (C, C_Bind, "bind"); pragma Import (C, C_Bind, "bind");
pragma Import (C, C_Close, "close"); pragma Import (C, C_Close, "close");
pragma Import (C, C_Gethostname, "gethostname"); pragma Import (C, C_Gethostname, "gethostname");
......
gcc/ada/g-socthi.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -71,7 +71,7 @@ package body GNAT.Sockets.Thin is ...@@ -71,7 +71,7 @@ package body GNAT.Sockets.Thin is
function Syscall_Accept function Syscall_Accept
(S : C.int; (S : C.int;
Addr : System.Address; 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"); pragma Import (C, Syscall_Accept, "accept");
function Syscall_Connect function Syscall_Connect
...@@ -99,7 +99,7 @@ package body GNAT.Sockets.Thin is ...@@ -99,7 +99,7 @@ package body GNAT.Sockets.Thin is
Len : C.int; Len : C.int;
Flags : C.int; Flags : C.int;
From : Sockaddr_In_Access; 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"); pragma Import (C, Syscall_Recvfrom, "recvfrom");
function Syscall_Send function Syscall_Send
...@@ -127,6 +127,11 @@ package body GNAT.Sockets.Thin is ...@@ -127,6 +127,11 @@ package body GNAT.Sockets.Thin is
procedure Disable_SIGPIPE (S : C.int); procedure Disable_SIGPIPE (S : C.int);
pragma Import (C, Disable_SIGPIPE, "__gnat_disable_sigpipe"); 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; function Non_Blocking_Socket (S : C.int) return Boolean;
procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean); procedure Set_Non_Blocking_Socket (S : C.int; V : Boolean);
...@@ -137,7 +142,7 @@ package body GNAT.Sockets.Thin is ...@@ -137,7 +142,7 @@ package body GNAT.Sockets.Thin is
function C_Accept function C_Accept
(S : C.int; (S : C.int;
Addr : System.Address; Addr : System.Address;
Addrlen : access C.int) return C.int Addrlen : not null access C.int) return C.int
is is
R : C.int; R : C.int;
Val : aliased C.int := 1; Val : aliased C.int := 1;
...@@ -288,7 +293,7 @@ package body GNAT.Sockets.Thin is ...@@ -288,7 +293,7 @@ package body GNAT.Sockets.Thin is
Len : C.int; Len : C.int;
Flags : C.int; Flags : C.int;
From : Sockaddr_In_Access; From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int Fromlen : not null access C.int) return C.int
is is
Res : C.int; Res : C.int;
...@@ -404,6 +409,7 @@ package body GNAT.Sockets.Thin is ...@@ -404,6 +409,7 @@ package body GNAT.Sockets.Thin is
procedure Initialize (Process_Blocking_IO : Boolean) is procedure Initialize (Process_Blocking_IO : Boolean) is
begin begin
Thread_Blocking_IO := not Process_Blocking_IO; Thread_Blocking_IO := not Process_Blocking_IO;
Disable_All_SIGPIPEs;
end Initialize; end Initialize;
------------------------- -------------------------
...@@ -487,6 +493,32 @@ package body GNAT.Sockets.Thin is ...@@ -487,6 +493,32 @@ package body GNAT.Sockets.Thin is
Sin.Sin_Port := Port; Sin.Sin_Port := Port;
end Set_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 -- -- Socket_Error_Message --
-------------------------- --------------------------
......
gcc/ada/g-socthi.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -39,6 +39,7 @@ ...@@ -39,6 +39,7 @@
with Interfaces.C.Pointers; with Interfaces.C.Pointers;
with Interfaces.C.Strings; with Interfaces.C.Strings;
with GNAT.Sockets.Constants; with GNAT.Sockets.Constants;
with GNAT.OS_Lib; with GNAT.OS_Lib;
...@@ -204,14 +205,24 @@ package GNAT.Sockets.Thin is ...@@ -204,14 +205,24 @@ package GNAT.Sockets.Thin is
pragma Convention (C, Servent_Access); pragma Convention (C, Servent_Access);
-- Access to service entry -- Access to service entry
type Two_Int is array (0 .. 1) of C.int; type Two_Ints is array (0 .. 1) of C.int;
pragma Convention (C, Two_Int); pragma Convention (C, Two_Ints);
-- Used with pipe() -- 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 function C_Accept
(S : C.int; (S : C.int;
Addr : System.Address; Addr : System.Address;
Addrlen : access C.int) return C.int; Addrlen : not null access C.int) return C.int;
function C_Bind function C_Bind
(S : C.int; (S : C.int;
...@@ -241,7 +252,7 @@ package GNAT.Sockets.Thin is ...@@ -241,7 +252,7 @@ package GNAT.Sockets.Thin is
function C_Getpeername function C_Getpeername
(S : C.int; (S : C.int;
Name : System.Address; Name : System.Address;
Namelen : access C.int) return C.int; Namelen : not null access C.int) return C.int;
function C_Getservbyname function C_Getservbyname
(Name : C.char_array; (Name : C.char_array;
...@@ -254,14 +265,14 @@ package GNAT.Sockets.Thin is ...@@ -254,14 +265,14 @@ package GNAT.Sockets.Thin is
function C_Getsockname function C_Getsockname
(S : C.int; (S : C.int;
Name : System.Address; Name : System.Address;
Namelen : access C.int) return C.int; Namelen : not null access C.int) return C.int;
function C_Getsockopt function C_Getsockopt
(S : C.int; (S : C.int;
Level : C.int; Level : C.int;
Optname : C.int; Optname : C.int;
Optval : System.Address; Optval : System.Address;
Optlen : access C.int) return C.int; Optlen : not null access C.int) return C.int;
function C_Inet_Addr function C_Inet_Addr
(Cp : C.Strings.chars_ptr) return C.int; (Cp : C.Strings.chars_ptr) return C.int;
...@@ -292,7 +303,7 @@ package GNAT.Sockets.Thin is ...@@ -292,7 +303,7 @@ package GNAT.Sockets.Thin is
Len : C.int; Len : C.int;
Flags : C.int; Flags : C.int;
From : Sockaddr_In_Access; From : Sockaddr_In_Access;
Fromlen : access C.int) return C.int; Fromlen : not null access C.int) return C.int;
function C_Select function C_Select
(Nfds : C.int; (Nfds : C.int;
...@@ -342,6 +353,25 @@ package GNAT.Sockets.Thin is ...@@ -342,6 +353,25 @@ package GNAT.Sockets.Thin is
Iov : System.Address; Iov : System.Address;
Iovcnt : C.int) return C.int; 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 procedure Free_Socket_Set
(Set : Fd_Set_Access); (Set : Fd_Set_Access);
-- Free system-dependent socket set -- Free system-dependent socket set
...@@ -418,4 +448,5 @@ private ...@@ -418,4 +448,5 @@ private
pragma Import (C, New_Socket_Set, "__gnat_new_socket_set"); 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, Insert_Socket_In_Set, "__gnat_insert_socket_in_set");
pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set");
end GNAT.Sockets.Thin; end GNAT.Sockets.Thin;
gcc/ada/g-soliop-mingw.ads
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- S p e c -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -38,5 +38,5 @@ ...@@ -38,5 +38,5 @@
package GNAT.Sockets.Linker_Options is package GNAT.Sockets.Linker_Options is
private private
pragma Linker_Options ("-lwsock32"); pragma Linker_Options ("-lws2_32");
end GNAT.Sockets.Linker_Options; 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 @@ ...@@ -6,7 +6,7 @@
* * * *
* C Implementation File * * 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 * * 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- * * terms of the GNU General Public License as published by the Free Soft- *
...@@ -36,6 +36,11 @@ ...@@ -36,6 +36,11 @@
/* Include all the necessary system-specific headers and define the /* Include all the necessary system-specific headers and define the
necessary macros (shared with gen-soccon). */ 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" #include "raise.h"
/* Required for __gnat_malloc() */ /* Required for __gnat_malloc() */
...@@ -43,6 +48,10 @@ ...@@ -43,6 +48,10 @@
/* Required for memcpy() */ /* Required for memcpy() */
extern void __gnat_disable_sigpipe (int fd); 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_free_socket_set (fd_set *);
extern void __gnat_last_socket_in_set (fd_set *, int *); extern void __gnat_last_socket_in_set (fd_set *, int *);
extern void __gnat_get_socket_from_set (fd_set *, int *, int *); extern void __gnat_get_socket_from_set (fd_set *, int *, int *);
...@@ -50,7 +59,7 @@ extern void __gnat_insert_socket_in_set (fd_set *, int); ...@@ -50,7 +59,7 @@ extern void __gnat_insert_socket_in_set (fd_set *, int);
extern int __gnat_is_socket_in_set (fd_set *, int); extern int __gnat_is_socket_in_set (fd_set *, int);
extern fd_set *__gnat_new_socket_set (fd_set *); extern fd_set *__gnat_new_socket_set (fd_set *);
extern void __gnat_remove_socket_from_set (fd_set *, int); extern void __gnat_remove_socket_from_set (fd_set *, int);
extern int __gnat_get_h_errno (void); extern int __gnat_get_h_errno (void);
/* Disable the sending of SIGPIPE for writes on a broken stream */ /* Disable the sending of SIGPIPE for writes on a broken stream */
...@@ -63,6 +72,51 @@ __gnat_disable_sigpipe (int fd) ...@@ -63,6 +72,51 @@ __gnat_disable_sigpipe (int fd)
#endif #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. */ /* Free socket set. */
void void
...@@ -83,7 +137,7 @@ __gnat_last_socket_in_set (fd_set *set, int *last) ...@@ -83,7 +137,7 @@ __gnat_last_socket_in_set (fd_set *set, int *last)
int l; int l;
l = -1; l = -1;
#ifdef WINNT #ifdef _WIN32
/* More efficient method for NT. */ /* More efficient method for NT. */
for (s = 0; s < set->fd_count; s++) for (s = 0; s < set->fd_count; s++)
if ((int) set->fd_array[s] > l) 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