Skip to content

R
riscv-gcc-1
Commit ac72c9c5 by Arnaud Charlet
Options

[multiple changes] 

2009-04-29  Gary Dismukes  <dismukes@adacore.com>

	* exp_ch3.adb (Stream_Operation_OK): Return True for limited interfaces
	(other conditions permitting), so that abstract stream subprograms will
	be declared for them.

2009-04-29  Bob Duff  <duff@adacore.com>

	* g-expect.adb (Expect_Internal): Fix check for overfull buffer.

	* g-expect.ads: Minor comment fixes.

2009-04-29  Ed Schonberg  <schonberg@adacore.com>

	* freeze.adb, lib-xref.adb (Check_Dispatching_Operation): if the
	dispatching operation is a body without previous spec, update the list
	of primitive operations to ensure that cross-reference information is
	up-to-date.

2009-04-29  Albert Lee  <lee@adacore.com>

	* g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb,
	g-socthi-vxworks.ads, g-socthi-mingw.adb, g-socthi-mingw.ads,
	g-socthi.adb, g-socthi.ads, g-socket.adb, g-socket.ads
	(GNAT.Sockets.Thin.C_Readv,
	GNAT.Sockets.Thin.C_Writev): Remove unused subprograms.
	(GNAT.Sockets.Thin.C_Recvmsg,
	GNAT.Sockets.Thin.C_Sendmsg): New bindings to call recvmsg(2) and
	sendmsg(2).  
	(GNAT.Sockets.Receive_Vector, GNAT.Sockets.Send_Vector): Use
	C_Recvmsg/C_Sendmsg rather than Readv/C_Writev.

From-SVN: r146949
parent de0b4ad5
Showing with 580 additions and 314 deletions
gcc/ada/ChangeLog
2009-04-29 Gary Dismukes <dismukes@adacore.com>
* exp_ch3.adb (Stream_Operation_OK): Return True for limited interfaces
(other conditions permitting), so that abstract stream subprograms will
be declared for them.
2009-04-29 Bob Duff <duff@adacore.com>
* g-expect.adb (Expect_Internal): Fix check for overfull buffer.
* g-expect.ads: Minor comment fixes.
2009-04-29 Ed Schonberg <schonberg@adacore.com>
* freeze.adb, lib-xref.adb (Check_Dispatching_Operation): if the
dispatching operation is a body without previous spec, update the list
of primitive operations to ensure that cross-reference information is
up-to-date.
2009-04-29 Albert Lee <lee@adacore.com>
* g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb,
g-socthi-vxworks.ads, g-socthi-mingw.adb, g-socthi-mingw.ads,
g-socthi.adb, g-socthi.ads, g-socket.adb, g-socket.ads
(GNAT.Sockets.Thin.C_Readv,
GNAT.Sockets.Thin.C_Writev): Remove unused subprograms.
(GNAT.Sockets.Thin.C_Recvmsg,
GNAT.Sockets.Thin.C_Sendmsg): New bindings to call recvmsg(2) and
sendmsg(2).
(GNAT.Sockets.Receive_Vector, GNAT.Sockets.Send_Vector): Use
C_Recvmsg/C_Sendmsg rather than Readv/C_Writev.
2009-04-29 Ed Schonberg <schonberg@adacore.com>
* sem_disp.adb (Check_Dispatching_Operation): if the dispatching
......
gcc/ada/exp_ch3.adb
......@@ -8634,7 +8634,14 @@ package body Exp_Ch3 is
-- If the type is not limited, or else is limited but the attribute is
-- explicitly specified or is predefined for the type, then return True,
-- unless other conditions prevail, such as restrictions prohibiting
-- streams or dispatching operations.
-- streams or dispatching operations. We also return True for limited
-- interfaces, because they may be extended by nonlimited types and
-- permit inheritance in this case (addresses cases where an abstract
-- extension doesn't get 'Input declared, as per comments below, but
-- 'Class'Input must still be allowed). Note that attempts to apply
-- stream attributes to a limited interface or its class-wide type
-- (or limited extensions thereof) will still get properly rejected
-- by Check_Stream_Attribute.
-- We exclude the Input operation from being a predefined subprogram in
-- the case where the associated type is an abstract extension, because
......@@ -8648,6 +8655,7 @@ package body Exp_Ch3 is
-- exception.
return (not Is_Limited_Type (Typ)
or else Is_Interface (Typ)
or else Has_Predefined_Or_Specified_Stream_Attribute)
and then (Operation /= TSS_Stream_Input
or else not Is_Abstract_Type (Typ)
......
gcc/ada/freeze.adb
......@@ -36,7 +36,6 @@ with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util;
with Exp_Tss; use Exp_Tss;
with Layout; use Layout;
with Lib.Xref; use Lib.Xref;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
......@@ -135,10 +134,6 @@ package body Freeze is
-- the designated type. Otherwise freezing the access type does not freeze
-- the designated type.
procedure Generate_Prim_Op_References (Typ : Entity_Id);
-- For a tagged type, generate implicit references to its primitive
-- operations, for source navigation.
procedure Process_Default_Expressions
(E : Entity_Id;
After : in out Node_Id);
......@@ -2583,29 +2578,10 @@ package body Freeze is
-- Here for other than a subprogram or type
else
-- For a generic package, freeze types within, so that proper
-- cross-reference information is generated for tagged types.
-- This is the only freeze processing needed for generic packages.
if Ekind (E) = E_Generic_Package then
declare
T : Entity_Id;
begin
T := First_Entity (E);
while Present (T) loop
if Is_Type (T) then
Generate_Prim_Op_References (T);
end if;
Next_Entity (T);
end loop;
end;
-- If entity has a type, and it is not a generic unit, then
-- freeze it first (RM 13.14(10)).
elsif Present (Etype (E))
if Present (Etype (E))
and then Ekind (E) /= E_Generic_Function
then
Freeze_And_Append (Etype (E), Loc, Result);
......@@ -3598,10 +3574,6 @@ package body Freeze is
end if;
end if;
-- Generate references to primitive operations for a tagged type
Generate_Prim_Op_References (E);
-- Now that all types from which E may depend are frozen, see if the
-- size is known at compile time, if it must be unsigned, or if
-- strict alignment is required
......@@ -5145,72 +5117,6 @@ package body Freeze is
end Is_Fully_Defined;
---------------------------------
-- Generate_Prim_Op_References --
---------------------------------
procedure Generate_Prim_Op_References (Typ : Entity_Id) is
Base_T : Entity_Id;
Prim : Elmt_Id;
Prim_List : Elist_Id;
Ent : Entity_Id;
begin
-- Handle subtypes of synchronized types
if Ekind (Typ) = E_Protected_Subtype
or else Ekind (Typ) = E_Task_Subtype
then
Base_T := Etype (Typ);
else
Base_T := Typ;
end if;
-- References to primitive operations are only relevant for tagged types
if not Is_Tagged_Type (Base_T)
or else Is_Class_Wide_Type (Base_T)
then
return;
end if;
-- Ada 2005 (AI-345): For synchronized types generate reference
-- to the wrapper that allow us to dispatch calls through their
-- implemented abstract interface types.
-- The check for Present here is to protect against previously
-- reported critical errors.
if Is_Concurrent_Type (Base_T)
and then Present (Corresponding_Record_Type (Base_T))
then
Prim_List := Primitive_Operations
(Corresponding_Record_Type (Base_T));
else
Prim_List := Primitive_Operations (Base_T);
end if;
if No (Prim_List) then
return;
end if;
Prim := First_Elmt (Prim_List);
while Present (Prim) loop
-- If the operation is derived, get the original for cross-reference
-- reference purposes (it is the original for which we want the xref
-- and for which the comes_from_source test must be performed).
Ent := Node (Prim);
while Present (Alias (Ent)) loop
Ent := Alias (Ent);
end loop;
Generate_Reference (Typ, Ent, 'p', Set_Ref => False);
Next_Elmt (Prim);
end loop;
end Generate_Prim_Op_References;
---------------------------------
-- Process_Default_Expressions --
---------------------------------
......
gcc/ada/g-expect.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2000-2008, AdaCore --
-- Copyright (C) 2000-2009, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -660,7 +660,7 @@ package body GNAT.Expect is
else
-- Add what we read to the buffer
if Descriptors (J).Buffer_Index + N - 1 >
if Descriptors (J).Buffer_Index + N >
Descriptors (J).Buffer_Size
then
-- If the user wants to know when we have
......
gcc/ada/g-expect.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2000-2008, AdaCore --
-- Copyright (C) 2000-2009, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -63,10 +63,10 @@
-- Close (Fd);
-- You can also combine multiple regular expressions together, and get the
-- specific string matching a parenthesis pair by doing something like. If you
-- expect either "lang=optional ada" or "lang=ada" from the external process,
-- you can group the two together, which is more efficient, and simply get the
-- name of the language by doing:
-- specific string matching a parenthesis pair by doing something like this:
-- If you expect either "lang=optional ada" or "lang=ada" from the external
-- process, you can group the two together, which is more efficient, and
-- simply get the name of the language by doing:
-- declare
-- Matched : Match_Array (0 .. 2);
......@@ -116,10 +116,10 @@
-- -- Task Safety --
-- -----------------
-- This package is not task-safe: there should be not concurrent calls to
-- the functions defined in this package. In other words, separate tasks
-- may not access the facilities of this package without synchronization
-- that serializes access.
-- This package is not task-safe: there should not be concurrent calls to the
-- functions defined in this package. In other words, separate tasks must not
-- access the facilities of this package without synchronization that
-- serializes access.
with System;
with GNAT.OS_Lib;
......@@ -132,21 +132,21 @@ package GNAT.Expect is
Null_Pid : constant Process_Id := 0;
type Filter_Type is (Output, Input, Died);
-- The signals that are emitted by the Process_Descriptor upon state
-- changed in the child. One can connect to any of this signal through
-- the Add_Filter subprograms.
-- The signals that are emitted by the Process_Descriptor upon state change
-- in the child. One can connect to any of these signals through the
-- Add_Filter subprograms.
--
-- Output => Every time new characters are read from the process
-- associated with Descriptor, the filter is called with
-- these new characters in argument.
-- these new characters in the argument.
--
-- Note that output is only generated when the program is
-- Note that output is generated only when the program is
-- blocked in a call to Expect.
--
-- Input => Every time new characters are written to the process
-- associated with Descriptor, the filter is called with
-- these new characters in argument.
-- Note that input is only generated by calls to Send.
-- these new characters in the argument.
-- Note that input is generated only by calls to Send.
--
-- Died => The child process has died, or was explicitly killed
......@@ -172,16 +172,16 @@ package GNAT.Expect is
-- the process and/or automatic parsing of the output.
--
-- The expect buffer associated with that process can contain at most
-- Buffer_Size characters. Older characters are simply discarded when
-- this buffer is full. Beware that if the buffer is too big, this could
-- slow down the Expect calls if not output is matched, since Expect has
-- to match all the regexp against all the characters in the buffer.
-- If Buffer_Size is 0, there is no limit (i.e. all the characters are kept
-- Buffer_Size characters. Older characters are simply discarded when this
-- buffer is full. Beware that if the buffer is too big, this could slow
-- down the Expect calls if the output not is matched, since Expect has to
-- match all the regexp against all the characters in the buffer. If
-- Buffer_Size is 0, there is no limit (i.e. all the characters are kept
-- till Expect matches), but this is slower.
--
-- If Err_To_Out is True, then the standard error of the spawned process is
-- connected to the standard output. This is the only way to get the
-- Except subprograms also match on output on standard error.
-- Except subprograms to also match on output on standard error.
--
-- Invalid_Process is raised if the process could not be spawned.
......@@ -252,9 +252,9 @@ package GNAT.Expect is
--
-- Str is a string of all these characters.
--
-- User_Data, if specified, is a user specific data that will be passed to
-- the filter. Note that no checks are done on this parameter that should
-- be used with cautiousness.
-- User_Data, if specified, is user specific data that will be passed to
-- the filter. Note that no checks are done on this parameter, so it should
-- be used with caution.
procedure Add_Filter
(Descriptor : in out Process_Descriptor;
......@@ -262,10 +262,10 @@ package GNAT.Expect is
Filter_On : Filter_Type := Output;
User_Data : System.Address := System.Null_Address;
After : Boolean := False);
-- Add a new filter for one of the filter type. This filter will be
-- run before all the existing filters, unless After is set True,
-- in which case it will be run after existing filters. User_Data
-- is passed as is to the filter procedure.
-- Add a new filter for one of the filter types. This filter will be run
-- before all the existing filters, unless After is set True, in which case
-- it will be run after existing filters. User_Data is passed as is to the
-- filter procedure.
procedure Remove_Filter
(Descriptor : in out Process_Descriptor;
......@@ -277,14 +277,14 @@ package GNAT.Expect is
(Descriptor : Process_Descriptor'Class;
Str : String;
User_Data : System.Address := System.Null_Address);
-- Function that can be used a filter and that simply outputs Str on
-- Function that can be used as a filter and that simply outputs Str on
-- Standard_Output. This is mainly used for debugging purposes.
-- User_Data is ignored.
procedure Lock_Filters (Descriptor : in out Process_Descriptor);
-- Temporarily disables all output and input filters. They will be
-- reactivated only when Unlock_Filters has been called as many times as
-- Lock_Filters;
-- Lock_Filters.
procedure Unlock_Filters (Descriptor : in out Process_Descriptor);
-- Unlocks the filters. They are reactivated only if Unlock_Filters
......@@ -318,7 +318,7 @@ package GNAT.Expect is
-- If the buffer was full and some characters were discarded
Expect_Timeout : constant Expect_Match := -2;
-- If not output matching the regexps was found before the timeout
-- If no output matching the regexps was found before the timeout
function "+" (S : String) return GNAT.OS_Lib.String_Access;
-- Allocate some memory for the string. This is merely a convenience
......
gcc/ada/g-socket.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2008, AdaCore --
-- Copyright (C) 2001-2009, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -1657,6 +1657,41 @@ package body GNAT.Sockets is
From.Port := Port_Type (Network_To_Short (Sin.Sin_Port));
end Receive_Socket;
--------------------
-- Receive_Vector --
--------------------
procedure Receive_Vector
(Socket : Socket_Type;
Vector : Vector_Type;
Count : out Ada.Streams.Stream_Element_Count;
Flags : Request_Flag_Type := No_Request_Flag)
is
Res : ssize_t;
Msg : Msghdr :=
(Msg_Name => System.Null_Address,
Msg_Namelen => 0,
Msg_Iov => Vector'Address,
Msg_Iovlen => Vector'Length,
Msg_Control => System.Null_Address,
Msg_Controllen => 0,
Msg_Flags => 0);
begin
Res :=
C_Recvmsg
(C.int (Socket),
Msg'Address,
To_Int (Flags));
if Res = ssize_t (Failure) then
Raise_Socket_Error (Socket_Errno);
end if;
Count := Ada.Streams.Stream_Element_Count (Res);
end Receive_Vector;
-------------------
-- Resolve_Error --
-------------------
......@@ -1782,31 +1817,6 @@ package body GNAT.Sockets is
end if;
end Resolve_Exception;
--------------------
-- Receive_Vector --
--------------------
procedure Receive_Vector
(Socket : Socket_Type;
Vector : Vector_Type;
Count : out Ada.Streams.Stream_Element_Count)
is
Res : C.int;
begin
Res :=
C_Readv
(C.int (Socket),
Vector'Address,
Vector'Length);
if Res = Failure then
Raise_Socket_Error (Socket_Errno);
end if;
Count := Ada.Streams.Stream_Element_Count (Res);
end Receive_Vector;
-----------------
-- Send_Socket --
-----------------
......@@ -1891,11 +1901,15 @@ package body GNAT.Sockets is
procedure Send_Vector
(Socket : Socket_Type;
Vector : Vector_Type;
Count : out Ada.Streams.Stream_Element_Count)
Count : out Ada.Streams.Stream_Element_Count;
Flags : Request_Flag_Type := No_Request_Flag)
is
Res : C.int;
Iov_Count : C.int;
This_Iov_Count : C.int;
use type C.size_t;
Res : ssize_t;
Iov_Count : C.size_t;
This_Iov_Count : C.size_t;
Msg : Msghdr;
begin
Count := 0;
......@@ -1913,13 +1927,23 @@ package body GNAT.Sockets is
pragma Warnings (On);
Msg :=
(Msg_Name => System.Null_Address,
Msg_Namelen => 0,
Msg_Iov => Vector
(Vector'First + Integer (Iov_Count))'Address,
Msg_Iovlen => This_Iov_Count,
Msg_Control => System.Null_Address,
Msg_Controllen => 0,
Msg_Flags => 0);
Res :=
C_Writev
C_Sendmsg
(C.int (Socket),
Vector (Vector'First + Integer (Iov_Count))'Address,
This_Iov_Count);
Msg'Address,
Set_Forced_Flags (To_Int (Flags)));
if Res = Failure then
if Res = ssize_t (Failure) then
Raise_Socket_Error (Socket_Errno);
end if;
......
gcc/ada/g-socket.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2008, AdaCore --
-- Copyright (C) 2001-2009, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -913,9 +913,11 @@ package GNAT.Sockets is
procedure Receive_Vector
(Socket : Socket_Type;
Vector : Vector_Type;
Count : out Ada.Streams.Stream_Element_Count);
Count : out Ada.Streams.Stream_Element_Count;
Flags : Request_Flag_Type := No_Request_Flag);
-- Receive data from a socket and scatter it into the set of vector
-- elements Vector. Count is set to the count of received stream elements.
-- Flags allow control over reception.
function Resolve_Exception
(Occurrence : Ada.Exceptions.Exception_Occurrence) return Error_Type;
......@@ -959,9 +961,11 @@ package GNAT.Sockets is
procedure Send_Vector
(Socket : Socket_Type;
Vector : Vector_Type;
Count : out Ada.Streams.Stream_Element_Count);
Count : out Ada.Streams.Stream_Element_Count;
Flags : Request_Flag_Type := No_Request_Flag);
-- Transmit data gathered from the set of vector elements Vector to a
-- socket. Count is set to the count of transmitted stream elements.
-- Flags allow control over transmission.
procedure Set_Socket_Option
(Socket : Socket_Type;
......
gcc/ada/g-socthi-mingw.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2008, AdaCore --
-- Copyright (C) 2001-2009, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -247,38 +247,49 @@ package body GNAT.Sockets.Thin is
return Res;
end C_Connect;
-------------
-- C_Readv --
-------------
---------------
-- C_Recvmsg --
---------------
function C_Readv
(Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int
function C_Recvmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t
is
Res : C.int;
Count : C.int := 0;
Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
for Iovec'Address use Iov;
MH : Msghdr;
for MH'Address use Msg;
Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
for Iovec'Address use MH.Msg_Iov'Address;
pragma Import (Ada, Iovec);
pragma Unreferenced (Flags);
begin
-- Windows does not provide an implementation of recvmsg(). The
-- spec for WSARecvMsg() is incompatible with the data types we
-- define, and is not available in all versions of Windows. So,
-- we'll use C_Recv instead. Note that this means the Flags
-- argument is ignored.
for J in Iovec'Range loop
Res := C_Recv
(Fd,
(S,
Iovec (J).Base.all'Address,
C.int (Iovec (J).Length),
0);
if Res < 0 then
return Res;
return ssize_t (Res);
else
Count := Count + Res;
end if;
end loop;
return Count;
end C_Readv;
return ssize_t (Count);
end C_Recvmsg;
--------------
-- C_Select --
......@@ -372,26 +383,37 @@ package body GNAT.Sockets.Thin is
return Res;
end C_Select;
--------------
-- C_Writev --
--------------
---------------
-- C_Sendmsg --
---------------
function C_Writev
(Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int
function C_Sendmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t
is
Res : C.int;
Count : C.int := 0;
Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
for Iovec'Address use Iov;
MH : Msghdr;
for MH'Address use Msg;
Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element;
for Iovec'Address use MH.Msg_Iov'Address;
pragma Import (Ada, Iovec);
pragma Unreferenced (Flags);
begin
-- Windows does not provide an implementation of sendmsg(). The
-- spec for WSASendMsg() is incompatible with the data types we
-- define, and is not available in all versions of Windows. So,
-- we'll use C_Sendto instead. Note that this means the Flags
-- argument is ignored.
for J in Iovec'Range loop
Res := C_Sendto
(Fd,
(S,
Iovec (J).Base.all'Address,
C.int (Iovec (J).Length),
Flags => 0,
......@@ -399,13 +421,13 @@ package body GNAT.Sockets.Thin is
Tolen => 0);
if Res < 0 then
return Res;
return ssize_t (Res);
else
Count := Count + Res;
end if;
end loop;
return Count;
end C_Writev;
return ssize_t (Count);
end C_Sendmsg;
--------------
-- Finalize --
......
gcc/ada/g-socthi-mingw.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2008, AdaCore --
-- Copyright (C) 2001-2009, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -49,6 +49,22 @@ package GNAT.Sockets.Thin is
package C renames Interfaces.C;
use type C.size_t;
type ssize_t is range -(2 ** (C.size_t'Size - 1))
.. +(2 ** (C.size_t'Size - 1) - 1);
-- Signed type of the same size as size_t
type Msghdr is record
Msg_Name : System.Address;
Msg_Namelen : C.unsigned;
Msg_Iov : System.Address;
Msg_Iovlen : C.size_t;
Msg_Control : System.Address;
Msg_Controllen : C.size_t;
Msg_Flags : C.int;
end record;
pragma Convention (C, Msghdr);
function Socket_Errno return Integer;
-- Returns last socket error number
......@@ -124,11 +140,6 @@ package GNAT.Sockets.Thin is
(S : C.int;
Backlog : C.int) return C.int;
function C_Readv
(Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int;
function C_Recv
(S : C.int;
Msg : System.Address;
......@@ -143,6 +154,11 @@ package GNAT.Sockets.Thin is
From : Sockaddr_In_Access;
Fromlen : not null access C.int) return C.int;
function C_Recvmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t;
function C_Select
(Nfds : C.int;
Readfds : access Fd_Set;
......@@ -150,6 +166,11 @@ package GNAT.Sockets.Thin is
Exceptfds : access Fd_Set;
Timeout : Timeval_Access) return C.int;
function C_Sendmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t;
function C_Sendto
(S : C.int;
Msg : System.Address;
......@@ -180,11 +201,6 @@ package GNAT.Sockets.Thin is
function C_System
(Command : System.Address) return C.int;
function C_Writev
(Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int;
function WSAStartup
(WS_Version : Interfaces.C.int;
WSADataAddress : System.Address) return Interfaces.C.int;
......
gcc/ada/g-socthi-vms.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2008, AdaCore --
-- Copyright (C) 2001-2009, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -91,6 +91,18 @@ package body GNAT.Sockets.Thin is
Fromlen : not null access C.int) return C.int;
pragma Import (C, Syscall_Recvfrom, "recvfrom");
function Syscall_Recvmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return C.int;
pragma Import (C, Syscall_Recvmsg, "recvmsg");
function Syscall_Sendmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return C.int;
pragma Import (C, Syscall_Sendmsg, "sendmsg");
function Syscall_Sendto
(S : C.int;
Msg : System.Address;
......@@ -277,6 +289,54 @@ package body GNAT.Sockets.Thin is
return Res;
end C_Recvfrom;
---------------
-- C_Recvmsg --
---------------
function C_Recvmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t
is
Res : C.int;
begin
loop
Res := Syscall_Recvmsg (S, Msg, Flags);
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
return ssize_t (Res);
end C_Recvmsg;
---------------
-- C_Sendmsg --
---------------
function C_Sendmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t
is
Res : C.int;
begin
loop
Res := Syscall_Sendmsg (S, Msg, Flags);
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
return ssize_t (Res);
end C_Sendmsg;
--------------
-- C_Sendto --
--------------
......@@ -416,72 +476,4 @@ package body GNAT.Sockets.Thin is
end if;
end Socket_Error_Message;
-------------
-- C_Readv --
-------------
function C_Readv
(Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int
is
Res : C.int;
Count : C.int := 0;
Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
for Iovec'Address use Iov;
pragma Import (Ada, Iovec);
begin
for J in Iovec'Range loop
Res := C_Recv
(Fd,
Iovec (J).Base.all'Address,
Interfaces.C.int (Iovec (J).Length),
0);
if Res < 0 then
return Res;
else
Count := Count + Res;
end if;
end loop;
return Count;
end C_Readv;
--------------
-- C_Writev --
--------------
function C_Writev
(Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int
is
Res : C.int;
Count : C.int := 0;
Iovec : array (0 .. Iovcnt - 1) of Vector_Element;
for Iovec'Address use Iov;
pragma Import (Ada, Iovec);
begin
for J in Iovec'Range loop
Res := C_Sendto
(Fd,
Iovec (J).Base.all'Address,
Interfaces.C.int (Iovec (J).Length),
SOSC.MSG_Forced_Flags,
To => null,
Tolen => 0);
if Res < 0 then
return Res;
else
Count := Count + Res;
end if;
end loop;
return Count;
end C_Writev;
end GNAT.Sockets.Thin;
gcc/ada/g-socthi-vms.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2008, AdaCore --
-- Copyright (C) 2002-2009, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -52,6 +52,22 @@ package GNAT.Sockets.Thin is
package C renames Interfaces.C;
use type C.size_t;
type ssize_t is range -(2 ** (C.size_t'Size - 1))
.. +(2 ** (C.size_t'Size - 1) - 1);
-- Signed type of the same size as size_t
type Msghdr is record
Msg_Name : System.Address;
Msg_Namelen : C.int;
Msg_Iov : System.Address;
Msg_Iovlen : C.int;
Msg_Control : System.Address;
Msg_Controllen : C.int;
Msg_Flags : C.int;
end record;
pragma Convention (C, Msghdr);
function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
-- Returns last socket error number
......@@ -127,11 +143,6 @@ package GNAT.Sockets.Thin is
(S : C.int;
Backlog : C.int) return C.int;
function C_Readv
(Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int;
function C_Recv
(S : C.int;
Msg : System.Address;
......@@ -146,6 +157,11 @@ package GNAT.Sockets.Thin is
From : Sockaddr_In_Access;
Fromlen : not null access C.int) return C.int;
function C_Recvmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t;
function C_Select
(Nfds : C.int;
Readfds : access Fd_Set;
......@@ -153,6 +169,11 @@ package GNAT.Sockets.Thin is
Exceptfds : access Fd_Set;
Timeout : Timeval_Access) return C.int;
function C_Sendmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t;
function C_Sendto
(S : C.int;
Msg : System.Address;
......@@ -183,11 +204,6 @@ package GNAT.Sockets.Thin is
function C_System
(Command : System.Address) return C.int;
function C_Writev
(Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int;
-------------------------------------------------------
-- Signalling file descriptors for selector abortion --
-------------------------------------------------------
......
gcc/ada/g-socthi-vxworks.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2002-2008, AdaCore --
-- Copyright (C) 2002-2009, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -102,6 +102,18 @@ package body GNAT.Sockets.Thin is
Fromlen : not null access C.int) return C.int;
pragma Import (C, Syscall_Recvfrom, "recvfrom");
function Syscall_Recvmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return C.int;
pragma Import (C, Syscall_Recvmsg, "recvmsg");
function Syscall_Sendmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return C.int;
pragma Import (C, Syscall_Sendmsg, "sendmsg");
function Syscall_Sendto
(S : C.int;
Msg : System.Address;
......@@ -291,6 +303,54 @@ package body GNAT.Sockets.Thin is
return Res;
end C_Recvfrom;
---------------
-- C_Recvmsg --
---------------
function C_Recvmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t
is
Res : C.int;
begin
loop
Res := Syscall_Recvmsg (S, Msg, Flags);
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
return ssize_t (Res);
end C_Recvmsg;
---------------
-- C_Sendmsg --
---------------
function C_Sendmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t
is
Res : C.int;
begin
loop
Res := Syscall_Sendmsg (S, Msg, Flags);
exit when SOSC.Thread_Blocking_IO
or else Res /= Failure
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
return ssize_t (Res);
end C_Sendmsg;
--------------
-- C_Sendto --
--------------
......
gcc/ada/g-socthi-vxworks.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2002-2008, AdaCore --
-- Copyright (C) 2002-2009, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -50,6 +50,22 @@ package GNAT.Sockets.Thin is
package C renames Interfaces.C;
use type C.size_t;
type ssize_t is range -(2 ** (C.size_t'Size - 1))
.. +(2 ** (C.size_t'Size - 1) - 1);
-- Signed type of the same size as size_t
type Msghdr is record
Msg_Name : System.Address;
Msg_Namelen : C.unsigned;
Msg_Iov : System.Address;
Msg_Iovlen : C.int;
Msg_Control : System.Address;
Msg_Controllen : C.unsigned;
Msg_Flags : C.int;
end record;
pragma Convention (C, Msghdr);
function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
-- Returns last socket error number
......@@ -125,11 +141,6 @@ package GNAT.Sockets.Thin is
(S : C.int;
Backlog : C.int) return C.int;
function C_Readv
(Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int;
function C_Recv
(S : C.int;
Msg : System.Address;
......@@ -144,6 +155,11 @@ package GNAT.Sockets.Thin is
From : Sockaddr_In_Access;
Fromlen : not null access C.int) return C.int;
function C_Recvmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t;
function C_Select
(Nfds : C.int;
Readfds : access Fd_Set;
......@@ -151,6 +167,11 @@ package GNAT.Sockets.Thin is
Exceptfds : access Fd_Set;
Timeout : Timeval_Access) return C.int;
function C_Sendmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t;
function C_Sendto
(S : C.int;
Msg : System.Address;
......@@ -181,11 +202,6 @@ package GNAT.Sockets.Thin is
function C_System
(Command : System.Address) return C.int;
function C_Writev
(Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int;
-------------------------------------------------------
-- Signalling file descriptors for selector abortion --
-------------------------------------------------------
......@@ -224,11 +240,9 @@ private
pragma Import (C, C_Getsockname, "getsockname");
pragma Import (C, C_Getsockopt, "getsockopt");
pragma Import (C, C_Listen, "listen");
pragma Import (C, C_Readv, "readv");
pragma Import (C, C_Select, "select");
pragma Import (C, C_Setsockopt, "setsockopt");
pragma Import (C, C_Shutdown, "shutdown");
pragma Import (C, C_Strerror, "strerror");
pragma Import (C, C_System, "system");
pragma Import (C, C_Writev, "writev");
end GNAT.Sockets.Thin;
gcc/ada/g-socthi.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2008, AdaCore --
-- Copyright (C) 2001-2009, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -98,6 +98,18 @@ package body GNAT.Sockets.Thin is
Fromlen : not null access C.int) return C.int;
pragma Import (C, Syscall_Recvfrom, "recvfrom");
function Syscall_Recvmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t;
pragma Import (C, Syscall_Recvmsg, "recvmsg");
function Syscall_Sendmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t;
pragma Import (C, Syscall_Sendmsg, "sendmsg");
function Syscall_Sendto
(S : C.int;
Msg : System.Address;
......@@ -296,6 +308,54 @@ package body GNAT.Sockets.Thin is
return Res;
end C_Recvfrom;
---------------
-- C_Recvmsg --
---------------
function C_Recvmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t
is
Res : ssize_t;
begin
loop
Res := Syscall_Recvmsg (S, Msg, Flags);
exit when SOSC.Thread_Blocking_IO
or else Res /= ssize_t (Failure)
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
return Res;
end C_Recvmsg;
---------------
-- C_Sendmsg --
---------------
function C_Sendmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t
is
Res : ssize_t;
begin
loop
Res := Syscall_Sendmsg (S, Msg, Flags);
exit when SOSC.Thread_Blocking_IO
or else Res /= ssize_t (Failure)
or else Non_Blocking_Socket (S)
or else Errno /= SOSC.EWOULDBLOCK;
delay Quantum;
end loop;
return Res;
end C_Sendmsg;
--------------
-- C_Sendto --
--------------
......
gcc/ada/g-socthi.ads
......@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2001-2008, AdaCore --
-- Copyright (C) 2001-2009, AdaCore --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
......@@ -54,6 +54,22 @@ package GNAT.Sockets.Thin is
package C renames Interfaces.C;
use type C.size_t;
type ssize_t is range -(2 ** (C.size_t'Size - 1))
.. +(2 ** (C.size_t'Size - 1) - 1);
-- Signed type of the same size as size_t
type Msghdr is record
Msg_Name : System.Address;
Msg_Namelen : C.unsigned;
Msg_Iov : System.Address;
Msg_Iovlen : C.size_t;
Msg_Control : System.Address;
Msg_Controllen : C.size_t;
Msg_Flags : C.int;
end record;
pragma Convention (C, Msghdr);
function Socket_Errno return Integer renames GNAT.OS_Lib.Errno;
-- Returns last socket error number
......@@ -126,11 +142,6 @@ package GNAT.Sockets.Thin is
(S : C.int;
Backlog : C.int) return C.int;
function C_Readv
(Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int;
function C_Recv
(S : C.int;
Msg : System.Address;
......@@ -145,6 +156,11 @@ package GNAT.Sockets.Thin is
From : Sockaddr_In_Access;
Fromlen : not null access C.int) return C.int;
function C_Recvmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t;
function C_Select
(Nfds : C.int;
Readfds : access Fd_Set;
......@@ -152,6 +168,11 @@ package GNAT.Sockets.Thin is
Exceptfds : access Fd_Set;
Timeout : Timeval_Access) return C.int;
function C_Sendmsg
(S : C.int;
Msg : System.Address;
Flags : C.int) return ssize_t;
function C_Sendto
(S : C.int;
Msg : System.Address;
......@@ -182,11 +203,6 @@ package GNAT.Sockets.Thin is
function C_System
(Command : System.Address) return C.int;
function C_Writev
(Fd : C.int;
Iov : System.Address;
Iovcnt : C.int) return C.int;
-------------------------------------------------------
-- Signalling file descriptors for selector abortion --
-------------------------------------------------------
......@@ -249,13 +265,11 @@ private
pragma Import (C, C_Getsockname, "getsockname");
pragma Import (C, C_Getsockopt, "getsockopt");
pragma Import (C, C_Listen, "listen");
pragma Import (C, C_Readv, "readv");
pragma Import (C, C_Select, "select");
pragma Import (C, C_Setsockopt, "setsockopt");
pragma Import (C, C_Shutdown, "shutdown");
pragma Import (C, C_Strerror, "strerror");
pragma Import (C, C_System, "system");
pragma Import (C, C_Writev, "writev");
pragma Import (C, Nonreentrant_Gethostbyname, "gethostbyname");
pragma Import (C, Nonreentrant_Gethostbyaddr, "gethostbyaddr");
......
gcc/ada/lib-xref.adb
......@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2008, Free Software Foundation, Inc. --
-- Copyright (C) 1998-2009, 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- --
......@@ -93,6 +93,16 @@ package body Lib.Xref is
Table_Increment => Alloc.Xrefs_Increment,
Table_Name => "Xrefs");
------------------------
-- Local Subprograms --
------------------------
procedure Generate_Prim_Op_References (Typ : Entity_Id);
-- For a tagged type, generate implicit references to its primitive
-- operations, for source navigation. This is done right before emitting
-- cross-reference information rather than at the freeze point of the type
-- in order to handle late bodies that are primitive operations.
-------------------------
-- Generate_Definition --
-------------------------
......@@ -196,6 +206,72 @@ package body Lib.Xref is
end if;
end Generate_Operator_Reference;
---------------------------------
-- Generate_Prim_Op_References --
---------------------------------
procedure Generate_Prim_Op_References (Typ : Entity_Id) is
Base_T : Entity_Id;
Prim : Elmt_Id;
Prim_List : Elist_Id;
Ent : Entity_Id;
begin
-- Handle subtypes of synchronized types
if Ekind (Typ) = E_Protected_Subtype
or else Ekind (Typ) = E_Task_Subtype
then
Base_T := Etype (Typ);
else
Base_T := Typ;
end if;
-- References to primitive operations are only relevant for tagged types
if not Is_Tagged_Type (Base_T)
or else Is_Class_Wide_Type (Base_T)
then
return;
end if;
-- Ada 2005 (AI-345): For synchronized types generate reference
-- to the wrapper that allow us to dispatch calls through their
-- implemented abstract interface types.
-- The check for Present here is to protect against previously
-- reported critical errors.
if Is_Concurrent_Type (Base_T)
and then Present (Corresponding_Record_Type (Base_T))
then
Prim_List := Primitive_Operations
(Corresponding_Record_Type (Base_T));
else
Prim_List := Primitive_Operations (Base_T);
end if;
if No (Prim_List) then
return;
end if;
Prim := First_Elmt (Prim_List);
while Present (Prim) loop
-- If the operation is derived, get the original for cross-reference
-- reference purposes (it is the original for which we want the xref
-- and for which the comes_from_source test must be performed).
Ent := Node (Prim);
while Present (Alias (Ent)) loop
Ent := Alias (Ent);
end loop;
Generate_Reference (Typ, Ent, 'p', Set_Ref => False);
Next_Elmt (Prim);
end loop;
end Generate_Prim_Op_References;
------------------------
-- Generate_Reference --
------------------------
......@@ -1083,6 +1159,26 @@ package body Lib.Xref is
return;
end if;
-- First we add references to the primitive operations of tagged
-- types declared in the main unit.
Handle_Prim_Ops : declare
Ent : Entity_Id;
begin
for J in 1 .. Xrefs.Last loop
Ent := Xrefs.Table (J).Ent;
if Is_Type (Ent)
and then Is_Tagged_Type (Ent)
and then Ent = Base_Type (Ent)
and then In_Extended_Main_Source_Unit (Ent)
then
Generate_Prim_Op_References (Ent);
end if;
end loop;
end Handle_Prim_Ops;
-- Before we go ahead and output the references we have a problem
-- that needs dealing with. So far we have captured things that are
-- definitely referenced by the main unit, or defined in the main
......@@ -1198,9 +1294,11 @@ package body Lib.Xref is
function Parent_Op (E : Entity_Id) return Entity_Id is
Orig_Op : constant Entity_Id := Alias (E);
begin
if No (Orig_Op) then
return Empty;
elsif not Comes_From_Source (E)
and then not Has_Xref_Entry (Orig_Op)
and then Comes_From_Source (Orig_Op)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment