Commit f16d05d9 by Arnaud Charlet

[multiple changes]

2009-04-07  Thomas Quinot  <quinot@adacore.com>

	* g-sothco.ads (Int_Access): Remove extraneous access type (use
	anonymous access instead).
	(Get_Socket_From_Set): Fix incorrectly reverted formals
	Last and Socket to match the underlying C routine.

	* g-socket.adb
	(Get): Use named parameter associations instead of positional ones in
	call go Get_Socket_From_Set, since this routine has two formals of the
	same type.

	* g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb,
	g-socthi-vxworks.ads, g-socthi-mingw.ads, g-socthi.adb, g-socthi.ads:
	(C_Ioctl, Syscall_Ioctl): use "access C.int" instead of "Int_Access"
	for type of Arg formal.

	* sem_warn.adb: Minor reformatting

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

	* sem_util.adb (Has_Tagged_Component): Fix typo in loop that iterates
	over record components.

2009-04-07  Nicolas Roche  <roche@adacore.com>

	* gsocket.h:
	Don't include resolvLib.h on VxWorks 6 (kernel and rtp). This library
	has disappeared between VxWorks 6.4 and VxWorks 6.5
	In RTP mode use time.h instead of times.h

2009-04-07  Robert Dewar  <dewar@adacore.com>

	* exp_ch4.adb (Expand_N_Op_Concat): Improve lower bound handling

2009-04-07  Kevin Pouget  <pouget@adacore.com>

	* exp_dist.adb: Modify Build_From_Any_Fonction procedure to correct
	expanded code for constrained types.

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

	* sem_ch4.adb (Analyze_Overloaded_Selected_Component): implement
	AI05-105: in an object renaming declaration, anonymousness is a name
	resolution rule.

	sem_ch8.adb (Analyze_Object_Renaming): Ditto.

2009-04-07  Arnaud Charlet  <charlet@adacore.com>

	* g-comlin.adb (Expansion): Fix old regression: also return directory
	names when matching.

From-SVN: r145689
parent 2fc05e3d
2009-04-07 Thomas Quinot <quinot@adacore.com>
* g-sothco.ads (Int_Access): Remove extraneous access type (use
anonymous access instead).
(Get_Socket_From_Set): Fix incorrectly reverted formals
Last and Socket to match the underlying C routine.
* g-socket.adb
(Get): Use named parameter associations instead of positional ones in
call go Get_Socket_From_Set, since this routine has two formals of the
same type.
* g-socthi-vms.adb, g-socthi-vms.ads, g-socthi-vxworks.adb,
g-socthi-vxworks.ads, g-socthi-mingw.ads, g-socthi.adb, g-socthi.ads:
(C_Ioctl, Syscall_Ioctl): use "access C.int" instead of "Int_Access"
for type of Arg formal.
* sem_warn.adb: Minor reformatting
2009-04-07 Ed Schonberg <schonberg@adacore.com>
* sem_util.adb (Has_Tagged_Component): Fix typo in loop that iterates
over record components.
2009-04-07 Nicolas Roche <roche@adacore.com>
* gsocket.h:
Don't include resolvLib.h on VxWorks 6 (kernel and rtp). This library
has disappeared between VxWorks 6.4 and VxWorks 6.5
In RTP mode use time.h instead of times.h
2009-04-07 Robert Dewar <dewar@adacore.com>
* exp_ch4.adb (Expand_N_Op_Concat): Improve lower bound handling
2009-04-07 Kevin Pouget <pouget@adacore.com>
* exp_dist.adb: Modify Build_From_Any_Fonction procedure to correct
expanded code for constrained types.
2009-04-07 Ed Schonberg <schonberg@adacore.com>
* sem_ch4.adb (Analyze_Overloaded_Selected_Component): implement
AI05-105: in an object renaming declaration, anonymousness is a name
resolution rule.
* sem_ch8.adb (Analyze_Object_Renaming): Ditto.
2009-04-07 Arnaud Charlet <charlet@adacore.com>
* g-comlin.adb (Expansion): Fix old regression: also return directory
names when matching.
2009-04-07 Robert Dewar <dewar@adacore.com> 2009-04-07 Robert Dewar <dewar@adacore.com>
* exp_ch4.adb: * exp_ch4.adb:
...@@ -2368,7 +2368,14 @@ package body Exp_Ch4 is ...@@ -2368,7 +2368,14 @@ package body Exp_Ch4 is
-- Set lower bound to lower bound of index subtype. This is not -- Set lower bound to lower bound of index subtype. This is not
-- right where the index subtype bound is dynamic ??? -- right where the index subtype bound is dynamic ???
Fixed_Low_Bound (NN) := Expr_Value (Type_Low_Bound (Ityp)); if Compile_Time_Known_Value (Type_Low_Bound (Ityp)) then
Fixed_Low_Bound (NN) :=
Expr_Value (Type_Low_Bound (Ityp));
else
Fixed_Low_Bound (NN) :=
Expr_Value (Type_Low_Bound (Base_Type (Ityp)));
end if;
Set := True; Set := True;
-- String literal case (can only occur for strings of course) -- String literal case (can only occur for strings of course)
......
...@@ -9114,39 +9114,82 @@ package body Exp_Dist is ...@@ -9114,39 +9114,82 @@ package body Exp_Dist is
New_Occurrence_Of (Any_Parameter, Loc), New_Occurrence_Of (Any_Parameter, Loc),
New_Occurrence_Of (Strm, Loc)))); New_Occurrence_Of (Strm, Loc))));
-- declare if Transmit_As_Unconstrained (Typ) then
-- Res : constant T := T'Input (Strm);
-- begin -- declare
-- Release_Buffer (Strm); -- Res : constant T := T'Input (Strm);
-- return Res; -- begin
-- end; -- Release_Buffer (Strm);
-- return Res;
Append_To (Stms, Make_Block_Statement (Loc, -- end;
Declarations => New_List (
Make_Object_Declaration (Loc, Append_To (Stms, Make_Block_Statement (Loc,
Defining_Identifier => Res, Declarations => New_List (
Constant_Present => True, Make_Object_Declaration (Loc,
Object_Definition => New_Occurrence_Of (Typ, Loc), Defining_Identifier => Res,
Expression => Constant_Present => True,
Make_Attribute_Reference (Loc, Object_Definition => New_Occurrence_Of (Typ, Loc),
Prefix => New_Occurrence_Of (Typ, Loc), Expression =>
Attribute_Name => Name_Input, Make_Attribute_Reference (Loc,
Expressions => New_List ( Prefix => New_Occurrence_Of (Typ, Loc),
Make_Attribute_Reference (Loc, Attribute_Name => Name_Input,
Prefix => New_Occurrence_Of (Strm, Loc), Expressions => New_List (
Attribute_Name => Name_Access))))), Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Strm, Loc),
Attribute_Name => Name_Access))))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_Release_Buffer), Loc),
Parameter_Associations =>
New_List (New_Occurrence_Of (Strm, Loc))),
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Res, Loc))))));
else
Handled_Statement_Sequence => -- declare
Make_Handled_Sequence_Of_Statements (Loc, -- Res : T;
Statements => New_List ( -- begin
Make_Procedure_Call_Statement (Loc, -- T'Read (Strm, Res);
Name => -- Release_Buffer (Strm);
New_Occurrence_Of (RTE (RE_Release_Buffer), Loc), -- return Res;
Parameter_Associations => -- end;
New_List (New_Occurrence_Of (Strm, Loc))),
Make_Simple_Return_Statement (Loc, Append_To (Stms, Make_Block_Statement (Loc,
Expression => New_Occurrence_Of (Res, Loc)))))); Declarations => New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => Res,
Constant_Present => False,
Object_Definition =>
New_Occurrence_Of (Typ, Loc))),
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
Attribute_Name => Name_Read,
Expressions => New_List (
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Strm, Loc),
Attribute_Name => Name_Access),
New_Occurrence_Of (Res, Loc))),
Make_Procedure_Call_Statement (Loc,
Name =>
New_Occurrence_Of
(RTE (RE_Release_Buffer), Loc),
Parameter_Associations =>
New_List (New_Occurrence_Of (Strm, Loc))),
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Res, Loc))))));
end if;
end; end;
end if; end if;
......
...@@ -263,24 +263,25 @@ package body GNAT.Command_Line is ...@@ -263,24 +263,25 @@ package body GNAT.Command_Line is
(It.Levels (Current).Dir, It.Dir_Name (1 .. NL)); (It.Levels (Current).Dir, It.Dir_Name (1 .. NL));
end if; end if;
end if; end if;
end if;
-- If not a directory, check the relative path against the pattern -- Check the relative path against the pattern.
-- Note that we try to match also against directory names, since
-- clients of this function may expect to retrieve directories.
else declare
declare Name : String :=
Name : String := It.Dir_Name (It.Start .. It.Levels (Current).Name_Last)
It.Dir_Name (It.Start .. It.Levels (Current).Name_Last) & S (1 .. Last);
& S (1 .. Last); begin
begin Canonical_Case_File_Name (Name);
Canonical_Case_File_Name (Name);
-- If it matches return the relative path -- If it matches return the relative path
if GNAT.Regexp.Match (Name, Iterator.Regexp) then if GNAT.Regexp.Match (Name, Iterator.Regexp) then
return Name; return Name;
end if; end if;
end; end;
end if;
end loop; end loop;
end Expansion; end Expansion;
......
...@@ -58,6 +58,10 @@ package body GNAT.Sockets is ...@@ -58,6 +58,10 @@ package body GNAT.Sockets is
ENOERROR : constant := 0; ENOERROR : constant := 0;
Empty_Socket_Set : Socket_Set_Type;
-- Variable set in Initialize, and then used internally to provide an
-- initial value for Socket_Set_Type objects.
Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024; Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024;
-- The network database functions gethostbyname, gethostbyaddr, -- The network database functions gethostbyname, gethostbyaddr,
-- getservbyname and getservbyport can either be guaranteed task safe by -- getservbyname and getservbyport can either be guaranteed task safe by
...@@ -426,7 +430,7 @@ package body GNAT.Sockets is ...@@ -426,7 +430,7 @@ package body GNAT.Sockets is
Status : out Selector_Status; Status : out Selector_Status;
Timeout : Selector_Duration := Forever) Timeout : Selector_Duration := Forever)
is is
E_Socket_Set : Socket_Set_Type; -- (No_Socket, No_Fd_Set_Access) E_Socket_Set : Socket_Set_Type := Empty_Socket_Set;
begin begin
Check_Selector Check_Selector
(Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout); (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout);
...@@ -813,7 +817,7 @@ package body GNAT.Sockets is ...@@ -813,7 +817,7 @@ package body GNAT.Sockets is
begin begin
if Item.Last /= No_Socket then if Item.Last /= No_Socket then
Get_Socket_From_Set Get_Socket_From_Set
(Item.Set'Access, L'Unchecked_Access, S'Unchecked_Access); (Item.Set'Access, Last => L'Access, Socket => S'Access);
Item.Last := Socket_Type (L); Item.Last := Socket_Type (L);
Socket := Socket_Type (S); Socket := Socket_Type (S);
else else
...@@ -1208,6 +1212,33 @@ package body GNAT.Sockets is ...@@ -1208,6 +1212,33 @@ package body GNAT.Sockets is
return Socket'Img; return Socket'Img;
end Image; end Image;
-----------
-- Image --
-----------
function Image (Item : Socket_Set_Type) return String is
Socket_Set : Socket_Set_Type := Item;
begin
declare
Last_Img : constant String := Socket_Set.Last'Img;
Buffer : String
(1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length);
Index : Positive := 1;
Socket : Socket_Type;
begin
while not Is_Empty (Socket_Set) loop
Get (Socket_Set, Socket);
declare
Socket_Img : constant String := Socket'Img;
begin
Buffer (Index .. Index + Socket_Img'Length - 1) := Socket_Img;
Index := Index + Socket_Img'Length;
end;
end loop;
return "[" & Last_Img & "]" & Buffer (1 .. Index - 1);
end;
end Image;
--------------- ---------------
-- Inet_Addr -- -- Inet_Addr --
--------------- ---------------
...@@ -1270,6 +1301,8 @@ package body GNAT.Sockets is ...@@ -1270,6 +1301,8 @@ package body GNAT.Sockets is
begin begin
if not Initialized then if not Initialized then
Initialized := True; Initialized := True;
Empty_Socket_Set.Last := No_Socket;
Reset_Socket_Set (Empty_Socket_Set.Set'Access);
Thin.Initialize; Thin.Initialize;
end if; end if;
end Initialize; end Initialize;
......
...@@ -121,7 +121,7 @@ package GNAT.Sockets.Thin is ...@@ -121,7 +121,7 @@ package GNAT.Sockets.Thin is
function C_Ioctl function C_Ioctl
(S : C.int; (S : C.int;
Req : C.int; Req : C.int;
Arg : Int_Access) return C.int; Arg : access C.int) return C.int;
function C_Listen function C_Listen
(S : C.int; (S : C.int;
......
...@@ -73,7 +73,7 @@ package body GNAT.Sockets.Thin is ...@@ -73,7 +73,7 @@ package body GNAT.Sockets.Thin is
function Syscall_Ioctl function Syscall_Ioctl
(S : C.int; (S : C.int;
Req : C.int; Req : C.int;
Arg : Int_Access) return C.int; Arg : access C.int) return C.int;
pragma Import (C, Syscall_Ioctl, "ioctl"); pragma Import (C, Syscall_Ioctl, "ioctl");
function Syscall_Recv function Syscall_Recv
...@@ -148,7 +148,7 @@ package body GNAT.Sockets.Thin is ...@@ -148,7 +148,7 @@ package body GNAT.Sockets.Thin is
-- tracks sockets set in non-blocking mode by user. -- tracks sockets set in non-blocking mode by user.
Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
Discard := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Unchecked_Access); Discard := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Access);
end if; end if;
return R; return R;
...@@ -219,7 +219,7 @@ package body GNAT.Sockets.Thin is ...@@ -219,7 +219,7 @@ package body GNAT.Sockets.Thin is
function C_Ioctl function C_Ioctl
(S : C.int; (S : C.int;
Req : C.int; Req : C.int;
Arg : Int_Access) return C.int Arg : access C.int) return C.int
is is
begin begin
if not SOSC.Thread_Blocking_IO if not SOSC.Thread_Blocking_IO
...@@ -361,7 +361,7 @@ package body GNAT.Sockets.Thin is ...@@ -361,7 +361,7 @@ package body GNAT.Sockets.Thin is
-- Do not use C_Ioctl as this subprogram tracks sockets set -- Do not use C_Ioctl as this subprogram tracks sockets set
-- in non-blocking mode by user. -- in non-blocking mode by user.
Discard := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Unchecked_Access); Discard := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Access);
Set_Non_Blocking_Socket (R, False); Set_Non_Blocking_Socket (R, False);
end if; end if;
......
...@@ -124,7 +124,7 @@ package GNAT.Sockets.Thin is ...@@ -124,7 +124,7 @@ package GNAT.Sockets.Thin is
function C_Ioctl function C_Ioctl
(S : C.int; (S : C.int;
Req : C.int; Req : C.int;
Arg : Int_Access) return C.int; Arg : access C.int) return C.int;
function C_Listen function C_Listen
(S : C.int; (S : C.int;
......
...@@ -83,7 +83,7 @@ package body GNAT.Sockets.Thin is ...@@ -83,7 +83,7 @@ package body GNAT.Sockets.Thin is
function Syscall_Ioctl function Syscall_Ioctl
(S : C.int; (S : C.int;
Req : C.int; Req : C.int;
Arg : Int_Access) return C.int; Arg : access C.int) return C.int;
pragma Import (C, Syscall_Ioctl, "ioctl"); pragma Import (C, Syscall_Ioctl, "ioctl");
function Syscall_Recv function Syscall_Recv
...@@ -160,7 +160,7 @@ package body GNAT.Sockets.Thin is ...@@ -160,7 +160,7 @@ package body GNAT.Sockets.Thin is
-- tracks sockets set in non-blocking mode by user. -- tracks sockets set in non-blocking mode by user.
Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
Res := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Unchecked_Access); Res := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Access);
-- Is it OK to ignore result ??? -- Is it OK to ignore result ???
end if; end if;
...@@ -232,7 +232,7 @@ package body GNAT.Sockets.Thin is ...@@ -232,7 +232,7 @@ package body GNAT.Sockets.Thin is
function C_Ioctl function C_Ioctl
(S : C.int; (S : C.int;
Req : C.int; Req : C.int;
Arg : Int_Access) return C.int Arg : access C.int) return C.int
is is
begin begin
if not SOSC.Thread_Blocking_IO if not SOSC.Thread_Blocking_IO
...@@ -374,7 +374,7 @@ package body GNAT.Sockets.Thin is ...@@ -374,7 +374,7 @@ package body GNAT.Sockets.Thin is
-- Do not use C_Ioctl as this subprogram tracks sockets set -- Do not use C_Ioctl as this subprogram tracks sockets set
-- in non-blocking mode by user. -- in non-blocking mode by user.
Res := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Unchecked_Access); Res := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Access);
-- Is it OK to ignore result ??? -- Is it OK to ignore result ???
Set_Non_Blocking_Socket (R, False); Set_Non_Blocking_Socket (R, False);
end if; end if;
......
...@@ -122,7 +122,7 @@ package GNAT.Sockets.Thin is ...@@ -122,7 +122,7 @@ package GNAT.Sockets.Thin is
function C_Ioctl function C_Ioctl
(S : C.int; (S : C.int;
Req : C.int; Req : C.int;
Arg : Int_Access) return C.int; Arg : access C.int) return C.int;
function C_Listen function C_Listen
(S : C.int; (S : C.int;
......
...@@ -79,7 +79,7 @@ package body GNAT.Sockets.Thin is ...@@ -79,7 +79,7 @@ package body GNAT.Sockets.Thin is
function Syscall_Ioctl function Syscall_Ioctl
(S : C.int; (S : C.int;
Req : C.int; Req : C.int;
Arg : Int_Access) return C.int; Arg : access C.int) return C.int;
pragma Import (C, Syscall_Ioctl, "ioctl"); pragma Import (C, Syscall_Ioctl, "ioctl");
function Syscall_Recv function Syscall_Recv
...@@ -164,7 +164,7 @@ package body GNAT.Sockets.Thin is ...@@ -164,7 +164,7 @@ package body GNAT.Sockets.Thin is
-- tracks sockets set in non-blocking mode by user. -- tracks sockets set in non-blocking mode by user.
Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S));
Discard := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Unchecked_Access); Discard := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Access);
end if; end if;
Disable_SIGPIPE (R); Disable_SIGPIPE (R);
...@@ -237,7 +237,7 @@ package body GNAT.Sockets.Thin is ...@@ -237,7 +237,7 @@ package body GNAT.Sockets.Thin is
function C_Ioctl function C_Ioctl
(S : C.int; (S : C.int;
Req : C.int; Req : C.int;
Arg : Int_Access) return C.int Arg : access C.int) return C.int
is is
begin begin
if not SOSC.Thread_Blocking_IO if not SOSC.Thread_Blocking_IO
...@@ -379,7 +379,7 @@ package body GNAT.Sockets.Thin is ...@@ -379,7 +379,7 @@ package body GNAT.Sockets.Thin is
-- Do not use C_Ioctl as this subprogram tracks sockets set -- Do not use C_Ioctl as this subprogram tracks sockets set
-- in non-blocking mode by user. -- in non-blocking mode by user.
Discard := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Unchecked_Access); Discard := Syscall_Ioctl (R, SOSC.FIONBIO, Val'Access);
Set_Non_Blocking_Socket (R, False); Set_Non_Blocking_Socket (R, False);
end if; end if;
Disable_SIGPIPE (R); Disable_SIGPIPE (R);
......
...@@ -123,7 +123,7 @@ package GNAT.Sockets.Thin is ...@@ -123,7 +123,7 @@ package GNAT.Sockets.Thin is
function C_Ioctl function C_Ioctl
(S : C.int; (S : C.int;
Req : C.int; Req : C.int;
Arg : Int_Access) return C.int; Arg : access C.int) return C.int;
function C_Listen function C_Listen
(S : C.int; (S : C.int;
......
...@@ -247,14 +247,10 @@ package GNAT.Sockets.Thin_Common is ...@@ -247,14 +247,10 @@ package GNAT.Sockets.Thin_Common is
-- Socket sets management -- -- Socket sets management --
---------------------------- ----------------------------
type Int_Access is access all C.int;
pragma Convention (C, Int_Access);
-- Access to C integers
procedure Get_Socket_From_Set procedure Get_Socket_From_Set
(Set : access Fd_Set; (Set : access Fd_Set;
Socket : Int_Access; Last : access C.int;
Last : Int_Access); Socket : access C.int);
-- Get last socket in Socket and remove it from the socket set. The -- Get last socket in Socket and remove it from the socket set. The
-- parameter Last is a maximum value of the largest socket. This hint is -- parameter Last is a maximum value of the largest socket. This hint is
-- used to avoid scanning very large socket sets. After a call to -- used to avoid scanning very large socket sets. After a call to
...@@ -274,7 +270,7 @@ package GNAT.Sockets.Thin_Common is ...@@ -274,7 +270,7 @@ package GNAT.Sockets.Thin_Common is
procedure Last_Socket_In_Set procedure Last_Socket_In_Set
(Set : access Fd_Set; (Set : access Fd_Set;
Last : Int_Access); Last : access C.int);
-- Find the largest socket in the socket set. This is needed for select(). -- Find the largest socket in the socket set. This is needed for select().
-- When Last_Socket_In_Set is called, parameter Last is a maximum value of -- When Last_Socket_In_Set is called, parameter Last is a maximum value of
-- the largest socket. This hint is used to avoid scanning very large -- the largest socket. This hint is used to avoid scanning very large
......
...@@ -66,7 +66,7 @@ ...@@ -66,7 +66,7 @@
#include <vxWorks.h> #include <vxWorks.h>
#include <ioLib.h> #include <ioLib.h>
#include <hostLib.h> #include <hostLib.h>
#ifndef __RTP__ #if (_WRS_VXWORKS_MAJOR != 6) && ! defined (__RTP__)
#include <resolvLib.h> #include <resolvLib.h>
#endif #endif
#define SHUT_RD 0 #define SHUT_RD 0
...@@ -176,7 +176,7 @@ ...@@ -176,7 +176,7 @@
#endif #endif
#ifdef __vxworks #if defined (__vxworks) && ! defined (__RTP__)
#include <sys/times.h> #include <sys/times.h>
#else #else
#include <sys/time.h> #include <sys/time.h>
......
...@@ -2638,14 +2638,36 @@ package body Sem_Ch4 is ...@@ -2638,14 +2638,36 @@ package body Sem_Ch4 is
if Chars (Comp) = Chars (Sel) if Chars (Comp) = Chars (Sel)
and then Is_Visible_Component (Comp) and then Is_Visible_Component (Comp)
then then
Set_Entity (Sel, Comp);
Set_Etype (Sel, Etype (Comp));
Add_One_Interp (N, Etype (Comp), Etype (Comp));
-- This also specifies a candidate to resolve the name. -- AI05-105: if the context is an object renaming with
-- Further overloading will be resolved from context. -- an anonymous access type, the expected type of the
-- object must be anonymous. This is a name resolution rule.
Set_Etype (Nam, It.Typ); if Nkind (Parent (N)) /= N_Object_Renaming_Declaration
or else No (Access_Definition (Parent (N)))
or else Ekind (Etype (Comp)) = E_Anonymous_Access_Type
or else
Ekind (Etype (Comp)) = E_Anonymous_Access_Subprogram_Type
then
Set_Entity (Sel, Comp);
Set_Etype (Sel, Etype (Comp));
Add_One_Interp (N, Etype (Comp), Etype (Comp));
-- This also specifies a candidate to resolve the name.
-- Further overloading will be resolved from context.
-- The selector name itself does not carry overloading
-- information.
Set_Etype (Nam, It.Typ);
else
-- Nnamed access type in the context of a renaming
-- declaration with an access definition. Remove
-- inapplicable candidate.
Remove_Interp (I);
end if;
end if; end if;
Next_Entity (Comp); Next_Entity (Comp);
......
...@@ -767,7 +767,46 @@ package body Sem_Ch8 is ...@@ -767,7 +767,46 @@ package body Sem_Ch8 is
(Related_Nod => N, (Related_Nod => N,
N => Access_Definition (N)); N => Access_Definition (N));
Analyze_And_Resolve (Nam, T); Analyze (Nam);
-- Ada 2005 AI05-105: if the declaration has an anonymous access
-- type, the renamed object must also have an anonymous type, and
-- this is a name resolution rule. This was implicit in the last
-- part of the first sentence in 8.5.1.(3/2), and is made explicit
-- by this recent AI.
if not Is_Overloaded (Nam) then
if Ekind (Etype (Nam)) /= Ekind (T) then
Error_Msg_N
("Expect anonymous access type is object renaming", N);
end if;
else
declare
I : Interp_Index;
It : Interp;
Typ : Entity_Id := Empty;
begin
Get_First_Interp (Nam, I, It);
while Present (It.Typ) loop
if No (Typ) then
if Ekind (It.Typ) = Ekind (T)
and then Covers (T, It.Typ)
then
Typ := It.Typ;
Set_Etype (Nam, Typ);
Set_Is_Overloaded (Nam, False);
end if;
else
Error_Msg_N ("ambiguous expression in renaming", N);
end if;
Get_Next_Interp (I, It);
end loop;
end;
end if;
Resolve (Nam, T);
-- Ada 2005 (AI-231): "In the case where the type is defined by an -- Ada 2005 (AI-231): "In the case where the type is defined by an
-- access_definition, the renamed entity shall be of an access-to- -- access_definition, the renamed entity shall be of an access-to-
......
...@@ -4831,7 +4831,7 @@ package body Sem_Util is ...@@ -4831,7 +4831,7 @@ package body Sem_Util is
return True; return True;
end if; end if;
Comp := Next_Component (Typ); Next_Component (Comp);
end loop; end loop;
return False; return False;
......
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