# 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.
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
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
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
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
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
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
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
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
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 \
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 \
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)
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 \
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 \
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
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
--------------------
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;
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;
+ if Res = Failure then
+ Raise_Socket_Error (Socket_Errno);
+ end if;
Status := Aborted;
---------------------
procedure Create_Selector (Selector : out Selector_Type) is
- S0 : C.int;
- S1 : C.int;
- S2 : C.int;
- Res : C.int;
- Sin : aliased Sockaddr_In;
- Len : aliased C.int := Sin'Size / 8;
- Err : Integer;
+ Two_Fds : aliased Fd_Pair;
+ Res : C.int;
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;
-------------------
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;
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;
-- --
-- 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- --
WSAData_Dummy : array (1 .. 512) of C.int;
- WS_Version : constant := 16#0101#;
+ WS_Version : constant := 16#0202#;
Initialized : Boolean := False;
- SYSNOTREADY : constant := 10091;
- VERNOTSUPPORTED : constant := 10092;
- NOTINITIALISED : constant := 10093;
- EDISCON : constant := 10101;
+ SYSNOTREADY : constant := 10091;
+ VERNOTSUPPORTED : constant := 10092;
+ NOTINITIALISED : constant := 10093;
+ EDISCON : constant := 10101;
function Standard_Connect
(S : C.int;
-------------
function C_Readv
- (Socket : C.int;
+ (Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int
is
- Res : C.int;
+ Res : C.int;
Count : C.int := 0;
Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
begin
for J in Iovec'Range loop
Res := C_Recv
- (Socket,
+ (Fd,
Iovec (J).Base.all'Address,
C.int (Iovec (J).Length),
0);
--------------
function C_Writev
- (Socket : C.int;
+ (Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int
is
- Res : C.int;
+ Res : C.int;
Count : C.int := 0;
Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
begin
for J in Iovec'Range loop
Res := C_Send
- (Socket,
+ (Fd,
Iovec (J).Base.all'Address,
C.int (Iovec (J).Length),
0);
-- 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;
Sin.Sin_Port := Port;
end Set_Port;
+ --------------------
+ -- Signalling_Fds --
+ --------------------
+
+ package body Signalling_Fds is separate;
+
--------------------------
-- Socket_Error_Message --
--------------------------
-- --
-- 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- --
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");
No_Fd_Set : constant Fd_Set_Access := System.Null_Address;
type time_t is
- range -(2 ** (8 * Constants.SIZEOF_tv_sec - 1))
- .. 2 ** (8 * Constants.SIZEOF_tv_sec - 1) - 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))
- .. 2 ** (8 * Constants.SIZEOF_tv_usec - 1) - 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);
package Chars_Ptr_Pointers is
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 *)
type In_Addr is record
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
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;
Namelen : C.int) return C.int;
function C_Gethostbyaddr
- (Addr : System.Address;
- Length : C.int;
- Typ : C.int) return Hostent_Access;
+ (Addr : System.Address;
+ Len : C.int;
+ Typ : C.int) return Hostent_Access;
function C_Gethostbyname
(Name : C.char_array) return Hostent_Access;
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;
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;
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;
function C_Send
(S : C.int;
- Buf : System.Address;
+ Msg : System.Address;
Len : C.int;
Flags : C.int) return C.int;
Optlen : C.int) return C.int;
function C_Shutdown
- (S : C.int;
- How : C.int) return C.int;
+ (S : C.int;
+ How : C.int) return C.int;
function C_Socket
(Domain : C.int;
(Command : System.Address) return C.int;
function C_Writev
- (Socket : C.int;
+ (Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int;
(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
-- value if it is, zero if it is not.
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.
+ (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.
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;
procedure WSACleanup;
procedure Finalize;
- procedure Initialize (Process_Blocking_IO : Boolean := False);
+ procedure Initialize (Process_Blocking_IO : Boolean);
private
pragma Import (Stdcall, C_Accept, "accept");
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;
-- --
-- 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- --
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
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
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;
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;
Sin.Sin_Port := Port;
end Set_Port;
+ --------------------
+ -- Signalling_Fds --
+ --------------------
+
+ package body Signalling_Fds is separate;
+
--------------------------
-- Socket_Error_Message --
--------------------------
-- --
-- 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- --
-- This is the Alpha/VMS version
with Interfaces.C.Pointers;
-
with Interfaces.C.Strings;
+
with GNAT.Sockets.Constants;
with GNAT.OS_Lib;
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");
-- Set Sin.Sin_Family to Family
procedure Set_Port
- (Sin : Sockaddr_In_Access;
- Port : C.unsigned_short);
+ (Sin : Sockaddr_In_Access;
+ Port : C.unsigned_short);
pragma Inline (Set_Port);
-- Set Sin.Sin_Port to Port
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;
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;
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;
+ (Cp : C.Strings.chars_ptr) return C.int;
function C_Ioctl
(S : C.int;
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;
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;
Optlen : C.int) return C.int;
function C_Shutdown
- (S : C.int;
- How : C.int) return C.int;
+ (S : C.int;
+ How : C.int) return C.int;
function C_Socket
(Domain : C.int;
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
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;
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;
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
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
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;
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;
Sin.Sin_Port := Port;
end Set_Port;
+ --------------------
+ -- Signalling_Fds --
+ --------------------
+
+ package body Signalling_Fds is separate;
+
--------------------------
-- Socket_Error_Message --
--------------------------
-- --
-- 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- --
-- 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;
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".
-- Set Sin.Sin_Length to Len
procedure Set_Family
- (Sin : Sockaddr_In_Access;
- Family : C.int);
+ (Sin : Sockaddr_In_Access;
+ Family : C.int);
pragma Inline (Set_Family);
-- Set Sin.Sin_Family to Family
procedure Set_Port
- (Sin : Sockaddr_In_Access;
- Port : C.unsigned_short);
+ (Sin : Sockaddr_In_Access;
+ Port : C.unsigned_short);
pragma Inline (Set_Port);
-- Set Sin.Sin_Port to Port
procedure Set_Address
- (Sin : Sockaddr_In_Access;
- Address : In_Addr);
+ (Sin : Sockaddr_In_Access;
+ Address : In_Addr);
pragma Inline (Set_Address);
-- Set Sin.Sin_Addr to Address
-- Access to host entry
type Servent is record
- S_Name : C.Strings.chars_ptr;
- S_Aliases : Chars_Ptr_Pointers.Pointer;
- S_Port : C.int;
- S_Proto : C.Strings.chars_ptr;
+ S_Name : C.Strings.chars_ptr;
+ S_Aliases : Chars_Ptr_Pointers.Pointer;
+ S_Port : C.int;
+ S_Proto : C.Strings.chars_ptr;
end record;
pragma Convention (C, Servent);
-- Service entry
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;
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;
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;
function C_Ioctl
- (S : C.int;
- Req : C.int;
- Arg : Int_Access) return C.int;
+ (S : C.int;
+ 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;
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;
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
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;
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");
-- --
-- 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- --
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
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
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);
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;
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;
procedure Initialize (Process_Blocking_IO : Boolean) is
begin
Thread_Blocking_IO := not Process_Blocking_IO;
+ Disable_All_SIGPIPEs;
end Initialize;
-------------------------
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 --
--------------------------
-- --
-- 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- --
with Interfaces.C.Pointers;
with Interfaces.C.Strings;
+
with GNAT.Sockets.Constants;
with GNAT.OS_Lib;
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;
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;
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;
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;
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
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;
-- --
-- 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- --
package GNAT.Sockets.Linker_Options is
private
- pragma Linker_Options ("-lwsock32");
+ pragma Linker_Options ("-lws2_32");
end GNAT.Sockets.Linker_Options;
--- /dev/null
+------------------------------------------------------------------------------
+-- --
+-- 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;
* *
* 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- *
/* 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() */
/* 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 *);
extern int __gnat_is_socket_in_set (fd_set *, int);
extern fd_set *__gnat_new_socket_set (fd_set *);
extern void __gnat_remove_socket_from_set (fd_set *, int);
-extern int __gnat_get_h_errno (void);
+extern int __gnat_get_h_errno (void);
\f
/* Disable the sending of SIGPIPE for writes on a broken stream */
#endif
}
+void
+__gnat_disable_all_sigpipes (void)
+{
+#if !defined(SO_NOSIGPIPE) && !defined(MSG_NOSIGNAL) && defined(SIGPIPE)
+ (void) signal (SIGPIPE, SIG_IGN);
+#endif
+}
+\f
+#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);
+}
+\f
+/*
+ * 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);
+}
+\f
+/*
+ * 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
+\f
/* Free socket set. */
void
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)
projects / gcc.git / commitdiff