diff options
| author | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2007-06-06 10:13:25 +0000 |
|---|---|---|
| committer | charlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4> | 2007-06-06 10:13:25 +0000 |
| commit | 244de65defd519a1245551886fce58113a4b7b2a (patch) | |
| tree | baf058bd56d76dcabcd90188202b3f51c48b7a25 /gcc | |
| parent | 14526cae1f83e17cedbaf4477aa81263edfc038d (diff) | |
| download | gcc-244de65defd519a1245551886fce58113a4b7b2a.tar.gz | |
2007-04-20 Thomas Quinot <quinot@adacore.com>
Bob Duff <duff@adacore.com>
* g-soccon-freebsd.ads, g-soccon-vxworks.ads:,
g-soccon-aix.ads, g-soccon-irix.ads, g-soccon-hpux.ads,
g-soccon-solaris.ads, g-soccon-vms.ads, g-soccon-tru64.ads: Add new
constant Thread_Blocking_IO, always True by default, set False
on a per-runtime basis.
(Need_Netdb_Buffer): New constant.
* g-stheme.adb, g-sttsne.ads, g-sttsne-locking.ads,
g-sttsne-locking.adb, g-sttsne-vxworks.ads, g-sttsne-vxworks.adb: New
files.
* g-socthi-vxworks.ads, g-socthi-vxworks.adb,
g-socthi-vms.ads, g-socthi-vms.adb (Safe_Gethostbyname,
Safe_Gethostbyaddr, Safe_Getservbyname, Safe_Getservbyport): Use new
child package Task_Safe_NetDB
(Host_Error_Messages): Add stub body.
(GNAT.Sockets.Thin.Signalling_Fds): New procedure Close.
* g-soccon-mingw.ads: Add Windows-specific constants.
(Need_Netdb_Buffer): New constant.
(GNAT.Sockets.Thin.C_Inet_Addr, Windows version): Remove useless Ada
wrapper and import inet_addr(3) from the standard sockets library
directly instead.
(In_Addr): Add alignment clause.
(GNAT.Sockets.Thin.Signalling_Fds): New procedure Close.
git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@125358 138bc75d-0d04-0410-961f-82ee72b054a4
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/g-soccon-aix.ads | 15 | ||||
| -rw-r--r-- | gcc/ada/g-soccon-freebsd.ads | 19 | ||||
| -rw-r--r-- | gcc/ada/g-soccon-hpux.ads | 15 | ||||
| -rw-r--r-- | gcc/ada/g-soccon-irix.ads | 15 | ||||
| -rw-r--r-- | gcc/ada/g-soccon-mingw.ads | 27 | ||||
| -rw-r--r-- | gcc/ada/g-soccon-solaris.ads | 15 | ||||
| -rw-r--r-- | gcc/ada/g-soccon-tru64.ads | 15 | ||||
| -rw-r--r-- | gcc/ada/g-soccon-vms.ads | 15 | ||||
| -rw-r--r-- | gcc/ada/g-soccon-vxworks.ads | 15 | ||||
| -rw-r--r-- | gcc/ada/g-socthi-vms.adb | 34 | ||||
| -rw-r--r-- | gcc/ada/g-socthi-vms.ads | 93 | ||||
| -rw-r--r-- | gcc/ada/g-socthi-vxworks.adb | 157 | ||||
| -rw-r--r-- | gcc/ada/g-socthi-vxworks.ads | 64 | ||||
| -rw-r--r-- | gcc/ada/g-stheme.adb | 75 | ||||
| -rw-r--r-- | gcc/ada/g-sttsne-locking.adb | 442 | ||||
| -rw-r--r-- | gcc/ada/g-sttsne-locking.ads | 78 | ||||
| -rw-r--r-- | gcc/ada/g-sttsne-vxworks.adb | 202 | ||||
| -rw-r--r-- | gcc/ada/g-sttsne-vxworks.ads | 72 | ||||
| -rw-r--r-- | gcc/ada/g-sttsne.ads | 81 |
19 files changed, 1230 insertions, 219 deletions
diff --git a/gcc/ada/g-soccon-aix.ads b/gcc/ada/g-soccon-aix.ads index 06773f24c08..f96cad40896 100644 --- a/gcc/ada/g-soccon-aix.ads +++ b/gcc/ada/g-soccon-aix.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2007, 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- -- @@ -178,4 +178,17 @@ package GNAT.Sockets.Constants is SIZEOF_tv_sec : constant := 4; -- tv_sec SIZEOF_tv_usec : constant := 4; -- tv_usec + ---------------------------------------- + -- Properties of supported interfaces -- + ---------------------------------------- + + Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops + + ---------------------- + -- Additional flags -- + ---------------------- + + Thread_Blocking_IO : constant Boolean := True; + -- Set False for contexts where socket i/o are process blocking + end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-freebsd.ads b/gcc/ada/g-soccon-freebsd.ads index 964e75bc83b..045c8a095cf 100644 --- a/gcc/ada/g-soccon-freebsd.ads +++ b/gcc/ada/g-soccon-freebsd.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2007, 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- -- @@ -35,7 +35,7 @@ -- by the GNAT.Sockets package (g-socket.ads). This package should not be -- directly with'ed by an applications program. --- This is the version for i386-unknown-freebsd5.2.1 +-- This is the version for i386-unknown-freebsd6.1 -- This file is generated automatically, do not modify it by hand! Instead, -- make changes to gen-soccon.c and re-run it on each target. @@ -139,7 +139,7 @@ package GNAT.Sockets.Constants is MSG_PEEK : constant := 2; -- Peek at incoming data MSG_EOR : constant := 8; -- Send end of record MSG_WAITALL : constant := 64; -- Wait for full reception - MSG_NOSIGNAL : constant := -1; -- No SIGPIPE on send + MSG_NOSIGNAL : constant := 131072; -- No SIGPIPE on send MSG_Forced_Flags : constant := 0; -- Flags set on all send(2) calls @@ -178,4 +178,17 @@ package GNAT.Sockets.Constants is SIZEOF_tv_sec : constant := 4; -- tv_sec SIZEOF_tv_usec : constant := 4; -- tv_usec + ---------------------------------------- + -- Properties of supported interfaces -- + ---------------------------------------- + + Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops + + ---------------------- + -- Additional flags -- + ---------------------- + + Thread_Blocking_IO : constant Boolean := True; + -- Set False for contexts where socket i/o are process blocking + end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-hpux.ads b/gcc/ada/g-soccon-hpux.ads index 0b6012e0ee6..d2262176a52 100644 --- a/gcc/ada/g-soccon-hpux.ads +++ b/gcc/ada/g-soccon-hpux.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2007, 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- -- @@ -178,4 +178,17 @@ package GNAT.Sockets.Constants is SIZEOF_tv_sec : constant := 4; -- tv_sec SIZEOF_tv_usec : constant := 4; -- tv_usec + ---------------------------------------- + -- Properties of supported interfaces -- + ---------------------------------------- + + Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops + + ---------------------- + -- Additional flags -- + ---------------------- + + Thread_Blocking_IO : constant Boolean := True; + -- Set False for contexts where socket i/o are process blocking + end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-irix.ads b/gcc/ada/g-soccon-irix.ads index 3fd365c3470..7beb802a3ed 100644 --- a/gcc/ada/g-soccon-irix.ads +++ b/gcc/ada/g-soccon-irix.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2007, 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- -- @@ -178,4 +178,17 @@ package GNAT.Sockets.Constants is SIZEOF_tv_sec : constant := 4; -- tv_sec SIZEOF_tv_usec : constant := 4; -- tv_usec + ---------------------------------------- + -- Properties of supported interfaces -- + ---------------------------------------- + + Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops + + ---------------------- + -- Additional flags -- + ---------------------- + + Thread_Blocking_IO : constant Boolean := True; + -- Set False for contexts where socket i/o are process blocking + end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-mingw.ads b/gcc/ada/g-soccon-mingw.ads index f0c25c392b5..3e612a1a18c 100644 --- a/gcc/ada/g-soccon-mingw.ads +++ b/gcc/ada/g-soccon-mingw.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2007, 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- -- @@ -178,4 +178,29 @@ package GNAT.Sockets.Constants is SIZEOF_tv_sec : constant := 4; -- tv_sec SIZEOF_tv_usec : constant := 4; -- tv_usec + ---------------------------------------- + -- Properties of supported interfaces -- + ---------------------------------------- + + Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops + + ---------------------- + -- Additional flags -- + ---------------------- + + Thread_Blocking_IO : constant Boolean := True; + -- Set False for contexts where socket i/o are process blocking + + ------------------------------ + -- MinGW-specific constants -- + ------------------------------ + + -- These constants may be used only within the MinGW version of + -- GNAT.Sockets.Thin. + + WSASYSNOTREADY : constant := 10091; -- System not ready + WSAVERNOTSUPPORTED : constant := 10092; -- Version not supported + WSANOTINITIALISED : constant := 10093; -- Winsock not intialized + WSAEDISCON : constant := 10101; -- Disconnected + end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-solaris.ads b/gcc/ada/g-soccon-solaris.ads index 7204e975c51..26638a9b783 100644 --- a/gcc/ada/g-soccon-solaris.ads +++ b/gcc/ada/g-soccon-solaris.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2007, 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- -- @@ -178,4 +178,17 @@ package GNAT.Sockets.Constants is SIZEOF_tv_sec : constant := 4; -- tv_sec SIZEOF_tv_usec : constant := 4; -- tv_usec + ---------------------------------------- + -- Properties of supported interfaces -- + ---------------------------------------- + + Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops + + ---------------------- + -- Additional flags -- + ---------------------- + + Thread_Blocking_IO : constant Boolean := True; + -- Set False for contexts where socket i/o are process blocking + end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-tru64.ads b/gcc/ada/g-soccon-tru64.ads index b6d6836452d..5537151ac4f 100644 --- a/gcc/ada/g-soccon-tru64.ads +++ b/gcc/ada/g-soccon-tru64.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2007, 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- -- @@ -178,4 +178,17 @@ package GNAT.Sockets.Constants is SIZEOF_tv_sec : constant := 4; -- tv_sec SIZEOF_tv_usec : constant := 4; -- tv_usec + ---------------------------------------- + -- Properties of supported interfaces -- + ---------------------------------------- + + Need_Netdb_Buffer : constant := 0; -- Need buffer for Netdb ops + + ---------------------- + -- Additional flags -- + ---------------------- + + Thread_Blocking_IO : constant Boolean := True; + -- Set False for contexts where socket i/o are process blocking + end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-vms.ads b/gcc/ada/g-soccon-vms.ads index 85996efa3cd..ab6c761d9d0 100644 --- a/gcc/ada/g-soccon-vms.ads +++ b/gcc/ada/g-soccon-vms.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2007, 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- -- @@ -178,4 +178,17 @@ package GNAT.Sockets.Constants is SIZEOF_tv_sec : constant := 4; -- tv_sec SIZEOF_tv_usec : constant := 4; -- tv_usec + ---------------------------------------- + -- Properties of supported interfaces -- + ---------------------------------------- + + Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops + + ---------------------- + -- Additional flags -- + ---------------------- + + Thread_Blocking_IO : constant Boolean := True; + -- Set False for contexts where socket i/o are process blocking + end GNAT.Sockets.Constants; diff --git a/gcc/ada/g-soccon-vxworks.ads b/gcc/ada/g-soccon-vxworks.ads index 1accc7cc812..4168d2c9975 100644 --- a/gcc/ada/g-soccon-vxworks.ads +++ b/gcc/ada/g-soccon-vxworks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2000-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 2000-2007, 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- -- @@ -178,6 +178,19 @@ package GNAT.Sockets.Constants is SIZEOF_tv_sec : constant := 4; -- tv_sec SIZEOF_tv_usec : constant := 4; -- tv_usec + ---------------------------------------- + -- Properties of supported interfaces -- + ---------------------------------------- + + Need_Netdb_Buffer : constant := 1; -- Need buffer for Netdb ops + + ---------------------- + -- Additional flags -- + ---------------------- + + Thread_Blocking_IO : constant Boolean := True; + -- Set False for contexts where socket i/o are process blocking + -------------------------------- -- VxWorks-specific constants -- -------------------------------- diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb index 0ede7e7973d..bd27a32d2ec 100644 --- a/gcc/ada/g-socthi-vms.adb +++ b/gcc/ada/g-socthi-vms.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2001-2006, AdaCore -- +-- Copyright (C) 2001-2007, 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- -- @@ -52,12 +52,10 @@ package body GNAT.Sockets.Thin is -- been set in non-blocking mode by the user. Quantum : constant Duration := 0.2; - -- When Thread_Blocking_IO is False, we set sockets in + -- When Constants.Thread_Blocking_IO is False, we set sockets in -- non-blocking mode and we spend a period of time Quantum between -- two attempts on a blocking operation. - Thread_Blocking_IO : Boolean := True; - Unknown_System_Error : constant C.Strings.chars_ptr := C.Strings.New_String ("Unknown system error"); @@ -136,14 +134,14 @@ package body GNAT.Sockets.Thin is begin loop R := Syscall_Accept (S, Addr, Addrlen); - exit when Thread_Blocking_IO + exit when Constants.Thread_Blocking_IO or else R /= Failure or else Non_Blocking_Socket (S) or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; - if not Thread_Blocking_IO + if not Constants.Thread_Blocking_IO and then R /= Failure then -- A socket inherits the properties ot its server especially @@ -171,7 +169,7 @@ package body GNAT.Sockets.Thin is begin Res := Syscall_Connect (S, Name, Namelen); - if Thread_Blocking_IO + if Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) or else Errno /= Constants.EINPROGRESS @@ -229,7 +227,7 @@ package body GNAT.Sockets.Thin is Arg : Int_Access) return C.int is begin - if not Thread_Blocking_IO + if not Constants.Thread_Blocking_IO and then Req = Constants.FIONBIO then if Arg.all /= 0 then @@ -255,7 +253,7 @@ package body GNAT.Sockets.Thin is begin loop Res := Syscall_Recv (S, Msg, Len, Flags); - exit when Thread_Blocking_IO + exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) or else Errno /= Constants.EWOULDBLOCK; @@ -282,7 +280,7 @@ package body GNAT.Sockets.Thin is begin loop Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); - exit when Thread_Blocking_IO + exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) or else Errno /= Constants.EWOULDBLOCK; @@ -307,7 +305,7 @@ package body GNAT.Sockets.Thin is begin loop Res := Syscall_Send (S, Msg, Len, Flags); - exit when Thread_Blocking_IO + exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) or else Errno /= Constants.EWOULDBLOCK; @@ -334,7 +332,7 @@ package body GNAT.Sockets.Thin is begin loop Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); - exit when Thread_Blocking_IO + exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) or else Errno /= Constants.EWOULDBLOCK; @@ -362,7 +360,7 @@ package body GNAT.Sockets.Thin is begin R := Syscall_Socket (Domain, Typ, Protocol); - if not Thread_Blocking_IO + if not Constants.Thread_Blocking_IO and then R /= Failure then -- Do not use C_Ioctl as this subprogram tracks sockets set @@ -384,13 +382,19 @@ package body GNAT.Sockets.Thin is null; end Finalize; + ------------------------- + -- Host_Error_Messages -- + ------------------------- + + package body Host_Error_Messages is separate; + ---------------- -- Initialize -- ---------------- - procedure Initialize (Process_Blocking_IO : Boolean) is + procedure Initialize is begin - Thread_Blocking_IO := not Process_Blocking_IO; + null; end Initialize; ------------------------- diff --git a/gcc/ada/g-socthi-vms.ads b/gcc/ada/g-socthi-vms.ads index c1bd1164371..28b9dd0975f 100644 --- a/gcc/ada/g-socthi-vms.ads +++ b/gcc/ada/g-socthi-vms.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2006, AdaCore -- +-- Copyright (C) 2002-2007, 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- -- @@ -40,8 +40,8 @@ with Interfaces.C.Pointers; with Interfaces.C.Strings; -with GNAT.Sockets.Constants; with GNAT.OS_Lib; +with GNAT.Sockets.Constants; with System; @@ -65,12 +65,21 @@ package GNAT.Sockets.Thin is 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". + -- not known, returns "Unknown system error". function Host_Errno return Integer; pragma Import (C, Host_Errno, "__gnat_get_h_errno"); -- Returns last host error number + package Host_Error_Messages is + + function Host_Error_Message + (H_Errno : Integer) return C.Strings.chars_ptr; + -- Returns the error message string for the host error number H_Errno. + -- If H_Errno is not known, returns "Unknown system error". + + end Host_Error_Messages; + subtype Fd_Set_Access is System.Address; No_Fd_Set : constant Fd_Set_Access := System.Null_Address; @@ -112,8 +121,11 @@ package GNAT.Sockets.Thin is type In_Addr is record S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; end record; + for In_Addr'Alignment use C.int'Alignment; pragma Convention (C, In_Addr); - -- Internet address + -- IPv4 address, represented as a network-order C.int. Note that the + -- underlying operating system may assume that values of this type have + -- C.int alignment, so we need to provide a suitable alignment clause here. type In_Addr_Access is access all In_Addr; pragma Convention (C, In_Addr_Access); @@ -220,6 +232,10 @@ package GNAT.Sockets.Thin is -- Indices into an Fd_Pair value providing access to each of the connected -- file descriptors. + -------------------------------- + -- Standard library functions -- + -------------------------------- + function C_Accept (S : C.int; Addr : System.Address; @@ -238,14 +254,6 @@ package GNAT.Sockets.Thin is Name : System.Address; Namelen : C.int) return C.int; - function C_Gethostbyaddr - (Addr : System.Address; - Len : C.int; - Typ : C.int) return Hostent_Access; - - function C_Gethostbyname - (Name : C.char_array) return Hostent_Access; - function C_Gethostname (Name : System.Address; Namelen : C.int) return C.int; @@ -255,14 +263,6 @@ package GNAT.Sockets.Thin is Name : System.Address; Namelen : not null access C.int) return C.int; - function C_Getservbyname - (Name : C.char_array; - Proto : C.char_array) return Servent_Access; - - function C_Getservbyport - (Port : C.int; - Proto : C.char_array) return Servent_Access; - function C_Getsockname (S : C.int; Name : System.Address; @@ -354,6 +354,10 @@ package GNAT.Sockets.Thin is Iov : System.Address; Iovcnt : C.int) return C.int; + ------------------------------------------------------- + -- Signalling file descriptors for selector abortion -- + ------------------------------------------------------- + package Signalling_Fds is function Create (Fds : not null access Fd_Pair) return C.int; @@ -371,8 +375,16 @@ package GNAT.Sockets.Thin is -- Write one byte of data to wsig, the write end of a pair of signalling -- fds created by Create_Signalling_Fds. + procedure Close (Sig : C.int); + pragma Convention (C, Close); + -- Close one end of a pair of signalling fds (ignoring any error) + end Signalling_Fds; + ---------------------------- + -- Socket sets management -- + ---------------------------- + procedure Free_Socket_Set (Set : Fd_Set_Access); -- Free system-dependent socket set @@ -381,11 +393,11 @@ package GNAT.Sockets.Thin is (Set : Fd_Set_Access; Socket : Int_Access; Last : Int_Access); - -- Get last socket in Socket and remove it from the socket - -- set. The parameter Last is a maximum value of the largest - -- socket. This hint is used to avoid scanning very large socket - -- sets. After a call to Get_Socket_From_Set, Last is set back to - -- the real largest socket in the socket set. + -- Get last socket in Socket and remove it from the socket set. The + -- parameter Last is a maximum value of the largest socket. This hint is + -- used to avoid scanning very large socket sets. After a call to + -- Get_Socket_From_Set, Last is set back to the real largest socket in the + -- socket set. procedure Insert_Socket_In_Set (Set : Fd_Set_Access; @@ -418,19 +430,35 @@ package GNAT.Sockets.Thin is Socket : C.int); -- Remove socket from the socket set + ------------------------------------------- + -- Nonreentrant network databases access -- + ------------------------------------------- + + function Nonreentrant_Gethostbyname + (Name : C.char_array) return Hostent_Access; + + function Nonreentrant_Gethostbyaddr + (Addr : System.Address; + Addr_Len : C.int; + Addr_Type : C.int) return Hostent_Access; + + function Nonreentrant_Getservbyname + (Name : C.char_array; + Proto : C.char_array) return Servent_Access; + + function Nonreentrant_Getservbyport + (Port : C.int; + Proto : C.char_array) return Servent_Access; + + procedure Initialize; procedure Finalize; - procedure Initialize (Process_Blocking_IO : Boolean); private pragma Import (C, C_Bind, "DECC$BIND"); pragma Import (C, C_Close, "DECC$CLOSE"); - pragma Import (C, C_Gethostbyaddr, "DECC$GETHOSTBYADDR"); - pragma Import (C, C_Gethostbyname, "DECC$GETHOSTBYNAME"); pragma Import (C, C_Gethostname, "DECC$GETHOSTNAME"); pragma Import (C, C_Getpeername, "DECC$GETPEERNAME"); - pragma Import (C, C_Getservbyname, "DECC$GETSERVBYNAME"); - pragma Import (C, C_Getservbyport, "DECC$GETSERVBYPORT"); pragma Import (C, C_Getsockname, "DECC$GETSOCKNAME"); pragma Import (C, C_Getsockopt, "DECC$GETSOCKOPT"); pragma Import (C, C_Inet_Addr, "DECC$INET_ADDR"); @@ -449,4 +477,9 @@ private 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, Nonreentrant_Gethostbyname, "DECC$GETHOSTBYNAME"); + pragma Import (C, Nonreentrant_Gethostbyaddr, "DECC$GETHOSTBYADDR"); + pragma Import (C, Nonreentrant_Getservbyname, "DECC$GETSERVBYNAME"); + pragma Import (C, Nonreentrant_Getservbyport, "DECC$GETSERVBYPORT"); + end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-vxworks.adb b/gcc/ada/g-socthi-vxworks.adb index e0539a9d12b..84394727f8e 100644 --- a/gcc/ada/g-socthi-vxworks.adb +++ b/gcc/ada/g-socthi-vxworks.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2002-2006, AdaCore -- +-- Copyright (C) 2002-2007, 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- -- @@ -41,7 +41,6 @@ with GNAT.OS_Lib; use GNAT.OS_Lib; with GNAT.Task_Lock; with Interfaces.C; use Interfaces.C; -with Unchecked_Conversion; package body GNAT.Sockets.Thin is @@ -57,32 +56,13 @@ package body GNAT.Sockets.Thin is -- been set in non-blocking mode by the user. Quantum : constant Duration := 0.2; - -- When Thread_Blocking_IO is False, we set sockets in + -- When Constants.Thread_Blocking_IO is False, we set sockets in -- non-blocking mode and we spend a period of time Quantum between -- two attempts on a blocking operation. - Thread_Blocking_IO : Boolean := True; - Unknown_System_Error : constant C.Strings.chars_ptr := C.Strings.New_String ("Unknown system error"); - -- The following types and variables are required to create a Hostent - -- record "by hand". - - type In_Addr_Access_Array_Access is access In_Addr_Access_Array; - - Alias_Access : constant Chars_Ptr_Pointers.Pointer := - new C.Strings.chars_ptr'(C.Strings.Null_Ptr); - - In_Addr_Access_Array_A : constant In_Addr_Access_Array_Access := - new In_Addr_Access_Array'(new In_Addr, null); - - In_Addr_Access_Ptr : constant In_Addr_Access_Pointers.Pointer := - In_Addr_Access_Array_A - (In_Addr_Access_Array_A'First)'Access; - - Local_Hostent : constant Hostent_Access := new Hostent; - ----------------------- -- Local Subprograms -- ----------------------- @@ -166,14 +146,14 @@ package body GNAT.Sockets.Thin is begin loop R := Syscall_Accept (S, Addr, Addrlen); - exit when Thread_Blocking_IO + exit when Constants.Thread_Blocking_IO or else R /= Failure or else Non_Blocking_Socket (S) or else Errno /= Constants.EWOULDBLOCK; delay Quantum; end loop; - if not Thread_Blocking_IO + if not Constants.Thread_Blocking_IO and then R /= Failure then -- A socket inherits the properties ot its server especially @@ -202,7 +182,7 @@ package body GNAT.Sockets.Thin is begin Res := Syscall_Connect (S, Name, Namelen); - if Thread_Blocking_IO + if Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) or else Errno /= Constants.EINPROGRESS @@ -251,97 +231,6 @@ package body GNAT.Sockets.Thin is end if; end C_Connect; - --------------------- - -- C_Gethostbyaddr -- - --------------------- - - function C_Gethostbyaddr - (Addr : System.Address; - Len : C.int; - Typ : C.int) return Hostent_Access - is - pragma Warnings (Off, Len); - pragma Warnings (Off, Typ); - - type int_Access is access int; - function To_Pointer is - new Unchecked_Conversion (System.Address, int_Access); - - function VxWorks_hostGetByAddr - (Addr : C.int; Buf : System.Address) return C.int; - pragma Import (C, VxWorks_hostGetByAddr, "hostGetByAddr"); - - Host_Name : aliased C.char_array (1 .. Max_Name_Length); - - begin - if VxWorks_hostGetByAddr (To_Pointer (Addr).all, - Host_Name (Host_Name'First)'Address) - /= Constants.OK - then - return null; - end if; - - In_Addr_Access_Ptr.all.all := To_In_Addr (To_Pointer (Addr).all); - Local_Hostent.all.H_Name := C.Strings.New_Char_Array (Host_Name); - - return Local_Hostent; - end C_Gethostbyaddr; - - --------------------- - -- C_Gethostbyname -- - --------------------- - - function C_Gethostbyname - (Name : C.char_array) return Hostent_Access - is - function VxWorks_hostGetByName - (Name : C.char_array) return C.int; - pragma Import (C, VxWorks_hostGetByName, "hostGetByName"); - - Addr : C.int; - - begin - Addr := VxWorks_hostGetByName (Name); - if Addr = Constants.ERROR then - return null; - end if; - - In_Addr_Access_Ptr.all.all := To_In_Addr (Addr); - Local_Hostent.all.H_Name := C.Strings.New_Char_Array (To_C (Host_Name)); - - return Local_Hostent; - end C_Gethostbyname; - - --------------------- - -- C_Getservbyname -- - --------------------- - - function C_Getservbyname - (Name : C.char_array; - Proto : C.char_array) return Servent_Access - is - pragma Warnings (Off, Name); - pragma Warnings (Off, Proto); - - begin - return null; - end C_Getservbyname; - - --------------------- - -- C_Getservbyport -- - --------------------- - - function C_Getservbyport - (Port : C.int; - Proto : C.char_array) return Servent_Access - is - pragma Warnings (Off, Port); - pragma Warnings (Off, Proto); - - begin - return null; - end C_Getservbyport; - ------------- -- C_Ioctl -- ------------- @@ -352,7 +241,7 @@ package body GNAT.Sockets.Thin is Arg : Int_Access) return C.int is begin - if not Thread_Blocking_IO + if not Constants.Thread_Blocking_IO and then Req = Constants.FIONBIO then if Arg.all /= 0 then @@ -378,7 +267,7 @@ package body GNAT.Sockets.Thin is begin loop Res := Syscall_Recv (S, Msg, Len, Flags); - exit when Thread_Blocking_IO + exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) or else Errno /= Constants.EWOULDBLOCK; @@ -405,7 +294,7 @@ package body GNAT.Sockets.Thin is begin loop Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); - exit when Thread_Blocking_IO + exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) or else Errno /= Constants.EWOULDBLOCK; @@ -430,7 +319,7 @@ package body GNAT.Sockets.Thin is begin loop Res := Syscall_Send (S, Msg, Len, Flags); - exit when Thread_Blocking_IO + exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) or else Errno /= Constants.EWOULDBLOCK; @@ -457,7 +346,7 @@ package body GNAT.Sockets.Thin is begin loop Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); - exit when Thread_Blocking_IO + exit when Constants.Thread_Blocking_IO or else Res /= Failure or else Non_Blocking_Socket (S) or else Errno /= Constants.EWOULDBLOCK; @@ -485,7 +374,7 @@ package body GNAT.Sockets.Thin is begin R := Syscall_Socket (Domain, Typ, Protocol); - if not Thread_Blocking_IO + if not Constants.Thread_Blocking_IO and then R /= Failure then -- Do not use C_Ioctl as this subprogram tracks sockets set @@ -508,13 +397,19 @@ package body GNAT.Sockets.Thin is null; end Finalize; + ------------------------- + -- Host_Error_Messages -- + ------------------------- + + package body Host_Error_Messages is separate; + ---------------- -- Initialize -- ---------------- - procedure Initialize (Process_Blocking_IO : Boolean) is + procedure Initialize is begin - Thread_Blocking_IO := not Process_Blocking_IO; + null; end Initialize; ------------------------- @@ -539,7 +434,7 @@ package body GNAT.Sockets.Thin is Address : In_Addr) is begin - Sin.Sin_Addr := Address; + Sin.Sin_Addr := Address; end Set_Address; ---------------- @@ -622,16 +517,4 @@ package body GNAT.Sockets.Thin is end if; end Socket_Error_Message; --- Package elaboration - -begin - Local_Hostent.all.H_Aliases := Alias_Access; - - -- VxWorks currently only supports AF_INET - - Local_Hostent.all.H_Addrtype := Constants.AF_INET; - - Local_Hostent.all.H_Length := 1; - Local_Hostent.all.H_Addr_List := In_Addr_Access_Ptr; - end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-vxworks.ads b/gcc/ada/g-socthi-vxworks.ads index 6e598b7dbc6..3e006a74089 100644 --- a/gcc/ada/g-socthi-vxworks.ads +++ b/gcc/ada/g-socthi-vxworks.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2002-2006, AdaCore -- +-- Copyright (C) 2002-2007, 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- -- @@ -42,8 +42,8 @@ with Interfaces.C.Strings; with Ada.Unchecked_Conversion; -with GNAT.Sockets.Constants; with GNAT.OS_Lib; +with GNAT.Sockets.Constants; with System; @@ -65,12 +65,21 @@ package GNAT.Sockets.Thin is 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". + -- not known, returns "Unknown system error". function Host_Errno return Integer; pragma Import (C, Host_Errno, "__gnat_get_h_errno"); -- Returns last host error number + package Host_Error_Messages is + + function Host_Error_Message + (H_Errno : Integer) return C.Strings.chars_ptr; + -- Returns the error message string for the host error number H_Errno. + -- If H_Errno is not known, returns "Unknown system error". + + end Host_Error_Messages; + subtype Fd_Set_Access is System.Address; No_Fd_Set : constant Fd_Set_Access := System.Null_Address; @@ -112,8 +121,11 @@ package GNAT.Sockets.Thin is type In_Addr is record S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; end record; + for In_Addr'Alignment use C.int'Alignment; pragma Convention (C, In_Addr); - -- Internet address + -- IPv4 address, represented as a network-order C.int. Note that the + -- underlying operating system may assume that values of this type have + -- C.int alignment, so we need to provide a suitable alignment clause here. function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr); @@ -223,6 +235,10 @@ package GNAT.Sockets.Thin is -- Indices into an Fd_Pair value providing access to each of the connected -- file descriptors. + -------------------------------- + -- Standard library functions -- + -------------------------------- + function C_Accept (S : C.int; Addr : System.Address; @@ -241,14 +257,6 @@ package GNAT.Sockets.Thin is Name : System.Address; Namelen : C.int) return C.int; - function C_Gethostbyaddr - (Addr : System.Address; - Len : C.int; - Typ : C.int) return Hostent_Access; - - function C_Gethostbyname - (Name : C.char_array) return Hostent_Access; - function C_Gethostname (Name : System.Address; Namelen : C.int) return C.int; @@ -258,14 +266,6 @@ package GNAT.Sockets.Thin is Name : System.Address; Namelen : not null access C.int) return C.int; - function C_Getservbyname - (Name : C.char_array; - Proto : C.char_array) return Servent_Access; - - function C_Getservbyport - (Port : C.int; - Proto : C.char_array) return Servent_Access; - function C_Getsockname (S : C.int; Name : System.Address; @@ -357,6 +357,10 @@ package GNAT.Sockets.Thin is Iov : System.Address; Iovcnt : C.int) return C.int; + ------------------------------------------------------- + -- Signalling file descriptors for selector abortion -- + ------------------------------------------------------- + package Signalling_Fds is function Create (Fds : not null access Fd_Pair) return C.int; @@ -374,8 +378,16 @@ package GNAT.Sockets.Thin is -- Write one byte of data to wsig, the write end of a pair of signalling -- fds created by Create_Signalling_Fds. + procedure Close (Sig : C.int); + pragma Convention (C, Close); + -- Close one end of a pair of signalling fds (ignoring any error) + end Signalling_Fds; + ---------------------------- + -- Socket sets management -- + ---------------------------- + procedure Free_Socket_Set (Set : Fd_Set_Access); -- Free system-dependent socket set @@ -384,11 +396,11 @@ package GNAT.Sockets.Thin is (Set : Fd_Set_Access; Socket : Int_Access; Last : Int_Access); - -- Get last socket in Socket and remove it from the socket - -- set. The parameter Last is a maximum value of the largest - -- socket. This hint is used to avoid scanning very large socket - -- sets. After a call to Get_Socket_From_Set, Last is set back to - -- the real largest socket in the socket set. + -- Get last socket in Socket and remove it from the socket set. The + -- parameter Last is a maximum value of the largest socket. This hint is + -- used to avoid scanning very large socket sets. After a call to + -- Get_Socket_From_Set, Last is set back to the real largest socket in the + -- socket set. procedure Insert_Socket_In_Set (Set : Fd_Set_Access; @@ -421,8 +433,8 @@ package GNAT.Sockets.Thin is Socket : C.int); -- Remove socket from the socket set + procedure Initialize; procedure Finalize; - procedure Initialize (Process_Blocking_IO : Boolean); private pragma Import (C, C_Bind, "bind"); diff --git a/gcc/ada/g-stheme.adb b/gcc/ada/g-stheme.adb new file mode 100644 index 00000000000..25d6c61921d --- /dev/null +++ b/gcc/ada/g-stheme.adb @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- GNAT.SOCKETS.THIN.HOST_ERROR_MESSAGES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007, 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 the default implementation of this unit, providing explicit +-- literal messages (we do not use hstrerror from the standard C library, +-- as this function is obsolete). + +separate (GNAT.Sockets.Thin) +package body Host_Error_Messages is + + package Messages is + HOST_NOT_FOUND : aliased char_array := "Host not found" & nul; + TRY_AGAIN : aliased char_array := "Try again" & nul; + NO_RECOVERY : aliased char_array := "No recovery" & nul; + NO_DATA : aliased char_array := "No address" & nul; + Unknown_Error : aliased char_array := "Unknown error" & nul; + end Messages; + + function Host_Error_Message (H_Errno : Integer) return C.Strings.chars_ptr + is + use Interfaces.C.Strings; + function TCP + (P : char_array_access; Nul_Check : Boolean := False) return chars_ptr + renames To_Chars_Ptr; + begin + case H_Errno is + when Constants.HOST_NOT_FOUND => + return TCP (Messages.HOST_NOT_FOUND'Access); + + when Constants.TRY_AGAIN => + return TCP (Messages.TRY_AGAIN'Access); + + when Constants.NO_RECOVERY => + return TCP (Messages.NO_RECOVERY'Access); + + when Constants.NO_DATA => + return TCP (Messages.NO_DATA'Access); + + when others => + return TCP (Messages.Unknown_Error'Access); + + end case; + end Host_Error_Message; + +end Host_Error_Messages; diff --git a/gcc/ada/g-sttsne-locking.adb b/gcc/ada/g-sttsne-locking.adb new file mode 100644 index 00000000000..5153fb79233 --- /dev/null +++ b/gcc/ada/g-sttsne-locking.adb @@ -0,0 +1,442 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N . T A S K _ S A F E _ N E T D B -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007, 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. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.Task_Lock; + +with Interfaces.C; use Interfaces.C; + +package body GNAT.Sockets.Thin.Task_Safe_NetDB is + + procedure Copy_Host_Entry + (Source_Hostent : Hostent; + Target_Hostent : out Hostent; + Target_Buffer : System.Address; + Target_Buffer_Length : C.int; + Result : out C.int); + -- Copy all the information from Source_Hostent into Target_Hostent, + -- using Target_Buffer to store associated data. + -- 0 is returned on success, -1 on failure (in case the provided buffer + -- is too small for the associated data). + + procedure Copy_Service_Entry + (Source_Servent : Servent; + Target_Servent : out Servent; + Target_Buffer : System.Address; + Target_Buffer_Length : C.int; + Result : out C.int); + -- Copy all the information from Source_Servent into Target_Servent, + -- using Target_Buffer to store associated data. + -- 0 is returned on success, -1 on failure (in case the provided buffer + -- is too small for the associated data). + + procedure Store_Name + (Name : char_array; + Storage : in out char_array; + Storage_Index : in out size_t; + Stored_Name : out C.Strings.chars_ptr); + -- Store the given Name at the first available location in Storage + -- (indicated by Storage_Index, which is updated afterwards), and return + -- the address of that location in Stored_Name. + -- (Supporting routine for the two below). + + --------------------- + -- Copy_Host_Entry -- + --------------------- + + procedure Copy_Host_Entry + (Source_Hostent : Hostent; + Target_Hostent : out Hostent; + Target_Buffer : System.Address; + Target_Buffer_Length : C.int; + Result : out C.int) + is + use type C.Strings.chars_ptr; + + Names_Length : size_t; + + Source_Aliases : Chars_Ptr_Array + renames Chars_Ptr_Pointers.Value + (Source_Hostent.H_Aliases, Terminator => C.Strings.Null_Ptr); + -- Null-terminated list of aliases (last element of this array is + -- Null_Ptr). + + Source_Addresses : In_Addr_Access_Array + renames In_Addr_Access_Pointers.Value + (Source_Hostent.H_Addr_List, Terminator => null); + + begin + Result := -1; + Names_Length := C.Strings.Strlen (Source_Hostent.H_Name) + 1; + + for J in Source_Aliases'Range loop + if Source_Aliases (J) /= C.Strings.Null_Ptr then + Names_Length := + Names_Length + C.Strings.Strlen (Source_Aliases (J)) + 1; + end if; + end loop; + + declare + type In_Addr_Array is array (Source_Addresses'Range) + of aliased In_Addr; + + type Netdb_Host_Data is record + Aliases_List : aliased Chars_Ptr_Array (Source_Aliases'Range); + Names : aliased char_array (1 .. Names_Length); + + Addresses_List : aliased In_Addr_Access_Array + (In_Addr_Array'Range); + Addresses : In_Addr_Array; + -- ??? This assumes support only for Inet family + + end record; + + Netdb_Data : Netdb_Host_Data; + pragma Import (Ada, Netdb_Data); + for Netdb_Data'Address use Target_Buffer; + + Names_Index : size_t := Netdb_Data.Names'First; + -- Index of first available location in Netdb_Data.Names + + begin + if Netdb_Data'Size / 8 > Target_Buffer_Length then + return; + end if; + + -- Copy host name + + Store_Name + (C.Strings.Value (Source_Hostent.H_Name), + Netdb_Data.Names, Names_Index, + Target_Hostent.H_Name); + + -- Copy aliases (null-terminated string pointer array) + + Target_Hostent.H_Aliases := + Netdb_Data.Aliases_List + (Netdb_Data.Aliases_List'First)'Unchecked_Access; + for J in Netdb_Data.Aliases_List'Range loop + if J = Netdb_Data.Aliases_List'Last then + Netdb_Data.Aliases_List (J) := C.Strings.Null_Ptr; + else + Store_Name + (C.Strings.Value (Source_Aliases (J)), + Netdb_Data.Names, Names_Index, + Netdb_Data.Aliases_List (J)); + end if; + end loop; + + -- Copy address type and length + + Target_Hostent.H_Addrtype := Source_Hostent.H_Addrtype; + Target_Hostent.H_Length := Source_Hostent.H_Length; + + -- Copy addresses + + Target_Hostent.H_Addr_List := + Netdb_Data.Addresses_List + (Netdb_Data.Addresses_List'First)'Unchecked_Access; + + for J in Netdb_Data.Addresses'Range loop + if J = Netdb_Data.Addresses'Last then + Netdb_Data.Addresses_List (J) := null; + else + Netdb_Data.Addresses_List (J) := + Netdb_Data.Addresses (J)'Unchecked_Access; + + Netdb_Data.Addresses (J) := Source_Addresses (J).all; + end if; + end loop; + end; + + Result := 0; + end Copy_Host_Entry; + + ------------------------ + -- Copy_Service_Entry -- + ------------------------ + + procedure Copy_Service_Entry + (Source_Servent : Servent; + Target_Servent : out Servent; + Target_Buffer : System.Address; + Target_Buffer_Length : C.int; + Result : out C.int) + is + use type C.Strings.chars_ptr; + + Names_Length : size_t; + + Source_Aliases : Chars_Ptr_Array + renames Chars_Ptr_Pointers.Value + (Source_Servent.S_Aliases, Terminator => C.Strings.Null_Ptr); + -- Null-terminated list of aliases (last element of this array is + -- Null_Ptr). + + begin + Result := -1; + Names_Length := C.Strings.Strlen (Source_Servent.S_Name) + 1 + + C.Strings.Strlen (Source_Servent.S_Proto) + 1; + + for J in Source_Aliases'Range loop + if Source_Aliases (J) /= C.Strings.Null_Ptr then + Names_Length := + Names_Length + C.Strings.Strlen (Source_Aliases (J)) + 1; + end if; + end loop; + + declare + type Netdb_Service_Data is record + Aliases_List : aliased Chars_Ptr_Array (Source_Aliases'Range); + Names : aliased char_array (1 .. Names_Length); + end record; + + Netdb_Data : Netdb_Service_Data; + pragma Import (Ada, Netdb_Data); + for Netdb_Data'Address use Target_Buffer; + + Names_Index : size_t := Netdb_Data.Names'First; + -- Index of first available location in Netdb_Data.Names + + begin + if Netdb_Data'Size / 8 > Target_Buffer_Length then + return; + end if; + + -- Copy service name + + Store_Name + (C.Strings.Value (Source_Servent.S_Name), + Netdb_Data.Names, Names_Index, + Target_Servent.S_Name); + + -- Copy aliases (null-terminated string pointer array) + + Target_Servent.S_Aliases := + Netdb_Data.Aliases_List + (Netdb_Data.Aliases_List'First)'Unchecked_Access; + + -- Copy port number + + Target_Servent.S_Port := Source_Servent.S_Port; + + -- Copy protocol name + + Store_Name + (C.Strings.Value (Source_Servent.S_Proto), + Netdb_Data.Names, Names_Index, + Target_Servent.S_Proto); + + for J in Netdb_Data.Aliases_List'Range loop + if J = Netdb_Data.Aliases_List'Last then + Netdb_Data.Aliases_List (J) := C.Strings.Null_Ptr; + else + Store_Name + (C.Strings.Value (Source_Aliases (J)), + Netdb_Data.Names, Names_Index, + Netdb_Data.Aliases_List (J)); + end if; + end loop; + end; + + Result := 0; + end Copy_Service_Entry; + + ------------------------ + -- Safe_Gethostbyaddr -- + ------------------------ + + function Safe_Gethostbyaddr + (Addr : System.Address; + Addr_Len : C.int; + Addr_Type : C.int; + Ret : not null access Hostent; + Buf : System.Address; + Buflen : C.int; + H_Errnop : not null access C.int) return C.int + is + HE : Hostent_Access; + Result : C.int; + begin + Result := -1; + GNAT.Task_Lock.Lock; + HE := Nonreentrant_Gethostbyaddr (Addr, Addr_Len, Addr_Type); + + if HE = null then + H_Errnop.all := C.int (Host_Errno); + goto Unlock_Return; + end if; + + -- Now copy the data to the user-provided buffer + + Copy_Host_Entry + (Source_Hostent => HE.all, + Target_Hostent => Ret.all, + Target_Buffer => Buf, + Target_Buffer_Length => Buflen, + Result => Result); + + <<Unlock_Return>> + GNAT.Task_Lock.Unlock; + return Result; + end Safe_Gethostbyaddr; + + ------------------------ + -- Safe_Gethostbyname -- + ------------------------ + + function Safe_Gethostbyname + (Name : C.char_array; + Ret : not null access Hostent; + Buf : System.Address; + Buflen : C.int; + H_Errnop : not null access C.int) return C.int + is + HE : Hostent_Access; + Result : C.int; + begin + Result := -1; + GNAT.Task_Lock.Lock; + HE := Nonreentrant_Gethostbyname (Name); + + if HE = null then + H_Errnop.all := C.int (Host_Errno); + goto Unlock_Return; + end if; + + -- Now copy the data to the user-provided buffer + + Copy_Host_Entry + (Source_Hostent => HE.all, + Target_Hostent => Ret.all, + Target_Buffer => Buf, + Target_Buffer_Length => Buflen, + Result => Result); + + <<Unlock_Return>> + GNAT.Task_Lock.Unlock; + return Result; + end Safe_Gethostbyname; + + ------------------------ + -- Safe_Getservbyname -- + ------------------------ + + function Safe_Getservbyname + (Name : C.char_array; + Proto : C.char_array; + Ret : not null access Servent; + Buf : System.Address; + Buflen : C.int) return C.int + is + SE : Servent_Access; + Result : C.int; + begin + Result := -1; + GNAT.Task_Lock.Lock; + SE := Nonreentrant_Getservbyname (Name, Proto); + + if SE = null then + goto Unlock_Return; + end if; + + -- Now copy the data to the user-provided buffer + + Copy_Service_Entry + (Source_Servent => SE.all, + Target_Servent => Ret.all, + Target_Buffer => Buf, + Target_Buffer_Length => Buflen, + Result => Result); + + <<Unlock_Return>> + GNAT.Task_Lock.Unlock; + return Result; + end Safe_Getservbyname; + + ------------------------ + -- Safe_Getservbyport -- + ------------------------ + + function Safe_Getservbyport + (Port : C.int; + Proto : C.char_array; + Ret : not null access Servent; + Buf : System.Address; + Buflen : C.int) return C.int + is + SE : Servent_Access; + Result : C.int; + + begin + Result := -1; + GNAT.Task_Lock.Lock; + SE := Nonreentrant_Getservbyport (Port, Proto); + + if SE = null then + goto Unlock_Return; + end if; + + -- Now copy the data to the user-provided buffer + + Copy_Service_Entry + (Source_Servent => SE.all, + Target_Servent => Ret.all, + Target_Buffer => Buf, + Target_Buffer_Length => Buflen, + Result => Result); + + <<Unlock_Return>> + GNAT.Task_Lock.Unlock; + return Result; + end Safe_Getservbyport; + + ---------------- + -- Store_Name -- + ---------------- + + procedure Store_Name + (Name : char_array; + Storage : in out char_array; + Storage_Index : in out size_t; + Stored_Name : out C.Strings.chars_ptr) + is + First : constant C.size_t := Storage_Index; + Last : constant C.size_t := Storage_Index + Name'Length - 1; + begin + Storage (First .. Last) := Name; + Stored_Name := C.Strings.To_Chars_Ptr + (Storage (First .. Last)'Unrestricted_Access); + Storage_Index := Last + 1; + end Store_Name; + +end GNAT.Sockets.Thin.Task_Safe_NetDB; diff --git a/gcc/ada/g-sttsne-locking.ads b/gcc/ada/g-sttsne-locking.ads new file mode 100644 index 00000000000..5b96cd3db96 --- /dev/null +++ b/gcc/ada/g-sttsne-locking.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N . T A S K _ S A F E _ N E T D B -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007, 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 version is used on VMS and LynxOS + +package GNAT.Sockets.Thin.Task_Safe_NetDB is + + ---------------------------------------- + -- Reentrant network databases access -- + ---------------------------------------- + + -- The following routines wrap the Nonreentrant_ versions using the task + -- lock, and copy the relevant data structures (under the lock) into the + -- result. The Nonreentrant_ versions are expected to be in the parent + -- package GNAT.Sockets.Thin (on platforms that use this version of + -- Task_Safe_NetDB). + + function Safe_Gethostbyname + (Name : C.char_array; + Ret : not null access Hostent; + Buf : System.Address; + Buflen : C.int; + H_Errnop : not null access C.int) return C.int; + + function Safe_Gethostbyaddr + (Addr : System.Address; + Addr_Len : C.int; + Addr_Type : C.int; + Ret : not null access Hostent; + Buf : System.Address; + Buflen : C.int; + H_Errnop : not null access C.int) return C.int; + + function Safe_Getservbyname + (Name : C.char_array; + Proto : C.char_array; + Ret : not null access Servent; + Buf : System.Address; + Buflen : C.int) return C.int; + + function Safe_Getservbyport + (Port : C.int; + Proto : C.char_array; + Ret : not null access Servent; + Buf : System.Address; + Buflen : C.int) return C.int; + +end GNAT.Sockets.Thin.Task_Safe_NetDB; diff --git a/gcc/ada/g-sttsne-vxworks.adb b/gcc/ada/g-sttsne-vxworks.adb new file mode 100644 index 00000000000..eaec069993d --- /dev/null +++ b/gcc/ada/g-sttsne-vxworks.adb @@ -0,0 +1,202 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N . T A S K _ S A F E _ N E T D B -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007, 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. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C; use Interfaces.C; + +package body GNAT.Sockets.Thin.Task_Safe_NetDB is + + -- The following additional data is returned by Safe_Gethostbyname + -- and Safe_Getostbyaddr in the user provided buffer. + + type Netdb_Host_Data (Name_Length : C.size_t) is record + Address : aliased In_Addr; + Addr_List : aliased In_Addr_Access_Array (0 .. 1); + Name : aliased C.char_array (0 .. Name_Length); + end record; + + Alias_Access : constant Chars_Ptr_Pointers.Pointer := + new C.Strings.chars_ptr'(C.Strings.Null_Ptr); + -- Constant used to create a Hostent record manually + + ------------------------ + -- Safe_Gethostbyaddr -- + ------------------------ + + function Safe_Gethostbyaddr + (Addr : System.Address; + Addr_Len : C.int; + Addr_Type : C.int; + Ret : not null access Hostent; + Buf : System.Address; + Buflen : C.int; + H_Errnop : not null access C.int) return C.int + is + type int_Access is access int; + function To_Pointer is + new Ada.Unchecked_Conversion (System.Address, int_Access); + + function VxWorks_hostGetByAddr + (Addr : C.int; Buf : System.Address) return C.int; + pragma Import (C, VxWorks_hostGetByAddr, "hostGetByAddr"); + + Netdb_Data : Netdb_Host_Data (Name_Length => Max_Name_Length); + pragma Import (Ada, Netdb_Data); + for Netdb_Data'Address use Buf; + + pragma Unreferenced (H_Errnop); + -- VxWorks does not provide h_errno + + begin + pragma Assert (Addr_Type = Constants.AF_INET); + pragma Assert (Addr_Len = In_Addr'Size / 8); + + -- Check that provided buffer is sufficiently large to hold the + -- data we want to return. + + if Netdb_Data'Size / 8 > Buflen then + return -1; + end if; + + if VxWorks_hostGetByAddr (To_Pointer (Addr).all, + Netdb_Data.Name'Address) + /= Constants.OK + then + return -1; + end if; + + Netdb_Data.Address := To_In_Addr (To_Pointer (Addr).all); + Netdb_Data.Addr_List := + (0 => Netdb_Data.Address'Unchecked_Access, + 1 => null); + + Ret.H_Name := C.Strings.To_Chars_Ptr + (Netdb_Data.Name'Unrestricted_Access); + Ret.H_Aliases := Alias_Access; + Ret.H_Addrtype := Constants.AF_INET; + Ret.H_Length := 4; + Ret.H_Addr_List := + Netdb_Data.Addr_List (Netdb_Data.Addr_List'First)'Unchecked_Access; + return 0; + end Safe_Gethostbyaddr; + + ------------------------ + -- Safe_Gethostbyname -- + ------------------------ + + function Safe_Gethostbyname + (Name : C.char_array; + Ret : not null access Hostent; + Buf : System.Address; + Buflen : C.int; + H_Errnop : not null access C.int) return C.int + is + function VxWorks_hostGetByName + (Name : C.char_array) return C.int; + pragma Import (C, VxWorks_hostGetByName, "hostGetByName"); + + Addr : C.int; + + pragma Unreferenced (H_Errnop); + -- VxWorks does not provide h_errno + + begin + Addr := VxWorks_hostGetByName (Name); + if Addr = Constants.ERROR then + return -1; + end if; + + declare + Netdb_Data : Netdb_Host_Data (Name_Length => Name'Length); + pragma Import (Ada, Netdb_Data); + for Netdb_Data'Address use Buf; + + begin + -- Check that provided buffer is sufficiently large to hold the + -- data we want to return. + + if Netdb_Data'Size / 8 > Buflen then + return -1; + end if; + + Netdb_Data.Address := To_In_Addr (Addr); + Netdb_Data.Addr_List := + (0 => Netdb_Data.Address'Unchecked_Access, + 1 => null); + Netdb_Data.Name (Netdb_Data.Name'First .. Name'Length - 1) := Name; + + Ret.H_Name := C.Strings.To_Chars_Ptr + (Netdb_Data.Name'Unrestricted_Access); + Ret.H_Aliases := Alias_Access; + Ret.H_Addrtype := Constants.AF_INET; + Ret.H_Length := 4; + Ret.H_Addr_List := + Netdb_Data.Addr_List (Netdb_Data.Addr_List'First)'Unchecked_Access; + end; + return 0; + end Safe_Gethostbyname; + + ------------------------ + -- Safe_Getservbyname -- + ------------------------ + + function Safe_Getservbyname + (Name : C.char_array; + Proto : C.char_array; + Ret : not null access Servent; + Buf : System.Address; + Buflen : C.int) return C.int + is + pragma Unreferenced (Name, Proto, Ret, Buf, Buflen); + begin + -- Not available under VxWorks + return -1; + end Safe_Getservbyname; + + ------------------------ + -- Safe_Getservbyport -- + ------------------------ + + function Safe_Getservbyport + (Port : C.int; + Proto : C.char_array; + Ret : not null access Servent; + Buf : System.Address; + Buflen : C.int) return C.int + is + pragma Unreferenced (Port, Proto, Ret, Buf, Buflen); + begin + -- Not available under VxWorks + return -1; + end Safe_Getservbyport; + +end GNAT.Sockets.Thin.Task_Safe_NetDB; diff --git a/gcc/ada/g-sttsne-vxworks.ads b/gcc/ada/g-sttsne-vxworks.ads new file mode 100644 index 00000000000..063ba12671f --- /dev/null +++ b/gcc/ada/g-sttsne-vxworks.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N . T A S K _ S A F E _ N E T D B -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007, 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 version is used on VxWorks + +package GNAT.Sockets.Thin.Task_Safe_NetDB is + + ---------------------------------------- + -- Reentrant network databases access -- + ---------------------------------------- + + function Safe_Gethostbyname + (Name : C.char_array; + Ret : not null access Hostent; + Buf : System.Address; + Buflen : C.int; + H_Errnop : not null access C.int) return C.int; + + function Safe_Gethostbyaddr + (Addr : System.Address; + Addr_Len : C.int; + Addr_Type : C.int; + Ret : not null access Hostent; + Buf : System.Address; + Buflen : C.int; + H_Errnop : not null access C.int) return C.int; + + function Safe_Getservbyname + (Name : C.char_array; + Proto : C.char_array; + Ret : not null access Servent; + Buf : System.Address; + Buflen : C.int) return C.int; + + function Safe_Getservbyport + (Port : C.int; + Proto : C.char_array; + Ret : not null access Servent; + Buf : System.Address; + Buflen : C.int) return C.int; + +end GNAT.Sockets.Thin.Task_Safe_NetDB; diff --git a/gcc/ada/g-sttsne.ads b/gcc/ada/g-sttsne.ads new file mode 100644 index 00000000000..c10534e2dbd --- /dev/null +++ b/gcc/ada/g-sttsne.ads @@ -0,0 +1,81 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N . T A S K _ S A F E _ N E T D B -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007, 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 package exports reentrant NetDB subprograms. This is the default +-- version, used on most platforms. The routines are implemented by importing +-- from C; see gsocket.h for details. Different versions are provided on +-- platforms where this functionality is implemented in Ada. + +package GNAT.Sockets.Thin.Task_Safe_NetDB is + + ---------------------------------------- + -- Reentrant network databases access -- + ---------------------------------------- + + function Safe_Gethostbyname + (Name : C.char_array; + Ret : not null access Hostent; + Buf : System.Address; + Buflen : C.int; + H_Errnop : not null access C.int) return C.int; + + function Safe_Gethostbyaddr + (Addr : System.Address; + Addr_Len : C.int; + Addr_Type : C.int; + Ret : not null access Hostent; + Buf : System.Address; + Buflen : C.int; + H_Errnop : not null access C.int) return C.int; + + function Safe_Getservbyname + (Name : C.char_array; + Proto : C.char_array; + Ret : not null access Servent; + Buf : System.Address; + Buflen : C.int) return C.int; + + function Safe_Getservbyport + (Port : C.int; + Proto : C.char_array; + Ret : not null access Servent; + Buf : System.Address; + Buflen : C.int) return C.int; + +private + pragma Import (C, Safe_Gethostbyname, "__gnat_safe_gethostbyname"); + pragma Import (C, Safe_Gethostbyaddr, "__gnat_safe_gethostbyaddr"); + pragma Import (C, Safe_Getservbyname, "__gnat_safe_getservbyname"); + pragma Import (C, Safe_Getservbyport, "__gnat_safe_getservbyport"); + +end GNAT.Sockets.Thin.Task_Safe_NetDB; |