summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorcharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2009-04-29 10:49:15 +0000
committercharlet <charlet@138bc75d-0d04-0410-961f-82ee72b054a4>2009-04-29 10:49:15 +0000
commita3e6563b2930eda54247c93617c90def3659c129 (patch)
tree0b6546d43b2e46559dc89368694673e09f48f367
parent86cf57b9cdb2979f0f96645567a9dca8ccb34bf7 (diff)
downloadgcc-a3e6563b2930eda54247c93617c90def3659c129.tar.gz
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. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@146949 138bc75d-0d04-0410-961f-82ee72b054a4
-rw-r--r--gcc/ada/ChangeLog32
-rw-r--r--gcc/ada/exp_ch3.adb10
-rw-r--r--gcc/ada/freeze.adb96
-rw-r--r--gcc/ada/g-expect.adb4
-rw-r--r--gcc/ada/g-expect.ads64
-rw-r--r--gcc/ada/g-socket.adb92
-rw-r--r--gcc/ada/g-socket.ads10
-rw-r--r--gcc/ada/g-socthi-mingw.adb76
-rw-r--r--gcc/ada/g-socthi-mingw.ads38
-rw-r--r--gcc/ada/g-socthi-vms.adb130
-rw-r--r--gcc/ada/g-socthi-vms.ads38
-rw-r--r--gcc/ada/g-socthi-vxworks.adb62
-rw-r--r--gcc/ada/g-socthi-vxworks.ads40
-rw-r--r--gcc/ada/g-socthi.adb62
-rw-r--r--gcc/ada/g-socthi.ads40
-rw-r--r--gcc/ada/lib-xref.adb100
16 files changed, 580 insertions, 314 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index c8767f10f58..aacaa5840cc 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,35 @@
+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
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 8ffb6e0cead..d05cdbba9e8 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/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)
diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb
index 7866432844e..fdacb091afc 100644
--- a/gcc/ada/freeze.adb
+++ b/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 --
---------------------------------
diff --git a/gcc/ada/g-expect.adb b/gcc/ada/g-expect.adb
index 124d43983a5..256f2564d8f 100644
--- a/gcc/ada/g-expect.adb
+++ b/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
diff --git a/gcc/ada/g-expect.ads b/gcc/ada/g-expect.ads
index 168a25554fb..31dda4134b1 100644
--- a/gcc/ada/g-expect.ads
+++ b/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
diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb
index cc31d142c57..70964053074 100644
--- a/gcc/ada/g-socket.adb
+++ b/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;
diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads
index 3680d751ff6..e84bd0fe996 100644
--- a/gcc/ada/g-socket.ads
+++ b/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;
diff --git a/gcc/ada/g-socthi-mingw.adb b/gcc/ada/g-socthi-mingw.adb
index c3a120f32a1..c77048671bc 100644
--- a/gcc/ada/g-socthi-mingw.adb
+++ b/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 --
diff --git a/gcc/ada/g-socthi-mingw.ads b/gcc/ada/g-socthi-mingw.ads
index e93b3f7be49..f06f7a80a55 100644
--- a/gcc/ada/g-socthi-mingw.ads
+++ b/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;
diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb
index afadbb2e5b8..14576805602 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-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;
diff --git a/gcc/ada/g-socthi-vms.ads b/gcc/ada/g-socthi-vms.ads
index 6a67e21d8a4..9725d91e855 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-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 --
-------------------------------------------------------
diff --git a/gcc/ada/g-socthi-vxworks.adb b/gcc/ada/g-socthi-vxworks.adb
index d035b61f807..0f682f4c04e 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-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 --
--------------
diff --git a/gcc/ada/g-socthi-vxworks.ads b/gcc/ada/g-socthi-vxworks.ads
index 04e1278f2be..91641550338 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-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;
diff --git a/gcc/ada/g-socthi.adb b/gcc/ada/g-socthi.adb
index fab5fb3ac9e..daf69140ed1 100644
--- a/gcc/ada/g-socthi.adb
+++ b/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 --
--------------
diff --git a/gcc/ada/g-socthi.ads b/gcc/ada/g-socthi.ads
index 303a942d385..31cbce8148f 100644
--- a/gcc/ada/g-socthi.ads
+++ b/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");
diff --git a/gcc/ada/lib-xref.adb b/gcc/ada/lib-xref.adb
index fac48642569..c2e1c59753c 100644
--- a/gcc/ada/lib-xref.adb
+++ b/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)