+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
-- 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
-- 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)
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;
-- 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);
-- 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);
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
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 --
---------------------------------
-- --
-- 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- --
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
-- --
-- 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- --
-- 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);
-- -- 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;
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
-- 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.
--
-- 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;
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;
(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
-- 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
-- --
-- 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- --
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 --
-------------------
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 --
-----------------
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;
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;
-- --
-- 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- --
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;
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;
-- --
-- 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- --
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 --
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,
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 --
-- --
-- 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- --
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
(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;
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;
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;
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;
-- --
-- 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- --
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;
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 --
--------------
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;
-- --
-- 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- --
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
(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;
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;
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;
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 --
-------------------------------------------------------
-- --
-- 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- --
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;
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 --
--------------
-- --
-- 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- --
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
(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;
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;
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;
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 --
-------------------------------------------------------
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;
-- --
-- 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- --
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;
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 --
--------------
-- --
-- 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- --
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
(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;
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;
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;
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 --
-------------------------------------------------------
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");
-- --
-- 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- --
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 --
-------------------------
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 --
------------------------
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
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)
projects / platform / upstream / gcc.git / commitdiff