From f16d05d91391edb8da0ac0091c8576c8724f8cdc Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 7 Apr 2009 18:15:57 +0200 Subject: [PATCH] [multiple changes] 2009-04-07 Thomas Quinot * 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 * sem_util.adb (Has_Tagged_Component): Fix typo in loop that iterates over record components. 2009-04-07 Nicolas Roche * 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 * exp_ch4.adb (Expand_N_Op_Concat): Improve lower bound handling 2009-04-07 Kevin Pouget * exp_dist.adb: Modify Build_From_Any_Fonction procedure to correct expanded code for constrained types. 2009-04-07 Ed Schonberg * 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 * g-comlin.adb (Expansion): Fix old regression: also return directory names when matching. From-SVN: r145689 --- gcc/ada/ChangeLog | 53 ++++++++++++++++++++++ gcc/ada/exp_ch4.adb | 9 +++- gcc/ada/exp_dist.adb | 105 ++++++++++++++++++++++++++++++------------- gcc/ada/g-comlin.adb | 29 ++++++------ gcc/ada/g-socket.adb | 37 ++++++++++++++- gcc/ada/g-socthi-mingw.ads | 2 +- gcc/ada/g-socthi-vms.adb | 8 ++-- gcc/ada/g-socthi-vms.ads | 2 +- gcc/ada/g-socthi-vxworks.adb | 8 ++-- gcc/ada/g-socthi-vxworks.ads | 2 +- gcc/ada/g-socthi.adb | 8 ++-- gcc/ada/g-socthi.ads | 2 +- gcc/ada/g-sothco.ads | 10 ++--- gcc/ada/gsocket.h | 4 +- gcc/ada/sem_ch4.adb | 34 +++++++++++--- gcc/ada/sem_ch8.adb | 41 ++++++++++++++++- gcc/ada/sem_util.adb | 2 +- gcc/ada/sem_warn.adb | 88 ++++++++++++++++++------------------ 18 files changed, 319 insertions(+), 125 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 664dfa8..ba39538 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,56 @@ +2009-04-07 Thomas Quinot + + * 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 + + * sem_util.adb (Has_Tagged_Component): Fix typo in loop that iterates + over record components. + +2009-04-07 Nicolas Roche + + * 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 + + * exp_ch4.adb (Expand_N_Op_Concat): Improve lower bound handling + +2009-04-07 Kevin Pouget + + * exp_dist.adb: Modify Build_From_Any_Fonction procedure to correct + expanded code for constrained types. + +2009-04-07 Ed Schonberg + + * 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 + + * g-comlin.adb (Expansion): Fix old regression: also return directory + names when matching. + 2009-04-07 Robert Dewar * exp_ch4.adb: diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 27c450d..fb11644 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -2368,7 +2368,14 @@ package body Exp_Ch4 is -- Set lower bound to lower bound of index subtype. This is not -- 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; -- String literal case (can only occur for strings of course) diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index 546bbcc..14136fd 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -9114,39 +9114,82 @@ package body Exp_Dist is New_Occurrence_Of (Any_Parameter, Loc), New_Occurrence_Of (Strm, Loc)))); - -- declare - -- Res : constant T := T'Input (Strm); - -- begin - -- Release_Buffer (Strm); - -- return Res; - -- end; - - Append_To (Stms, Make_Block_Statement (Loc, - Declarations => New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Res, - Constant_Present => True, - Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Input, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Strm, Loc), - Attribute_Name => Name_Access))))), + if Transmit_As_Unconstrained (Typ) then + + -- declare + -- Res : constant T := T'Input (Strm); + -- begin + -- Release_Buffer (Strm); + -- return Res; + -- end; + + Append_To (Stms, Make_Block_Statement (Loc, + Declarations => New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Res, + Constant_Present => True, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Input, + Expressions => New_List ( + 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 => - 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)))))); + -- declare + -- Res : T; + -- begin + -- T'Read (Strm, Res); + -- Release_Buffer (Strm); + -- return Res; + -- end; + + Append_To (Stms, Make_Block_Statement (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 if; diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb index b67d4fe..ba8ed16 100644 --- a/gcc/ada/g-comlin.adb +++ b/gcc/ada/g-comlin.adb @@ -263,24 +263,25 @@ package body GNAT.Command_Line is (It.Levels (Current).Dir, It.Dir_Name (1 .. NL)); 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 - Name : String := - It.Dir_Name (It.Start .. It.Levels (Current).Name_Last) - & S (1 .. Last); - begin - Canonical_Case_File_Name (Name); + declare + Name : String := + It.Dir_Name (It.Start .. It.Levels (Current).Name_Last) + & S (1 .. Last); + begin + 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 - return Name; - end if; - end; - end if; + if GNAT.Regexp.Match (Name, Iterator.Regexp) then + return Name; + end if; + end; end loop; end Expansion; diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index d14fae8..e586a2d 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -58,6 +58,10 @@ package body GNAT.Sockets is 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; -- The network database functions gethostbyname, gethostbyaddr, -- getservbyname and getservbyport can either be guaranteed task safe by @@ -426,7 +430,7 @@ package body GNAT.Sockets is Status : out Selector_Status; Timeout : Selector_Duration := Forever) is - E_Socket_Set : Socket_Set_Type; -- (No_Socket, No_Fd_Set_Access) + E_Socket_Set : Socket_Set_Type := Empty_Socket_Set; begin Check_Selector (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout); @@ -813,7 +817,7 @@ package body GNAT.Sockets is begin if Item.Last /= No_Socket then 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); Socket := Socket_Type (S); else @@ -1208,6 +1212,33 @@ package body GNAT.Sockets is return Socket'Img; 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 -- --------------- @@ -1270,6 +1301,8 @@ package body GNAT.Sockets is begin if not Initialized then Initialized := True; + Empty_Socket_Set.Last := No_Socket; + Reset_Socket_Set (Empty_Socket_Set.Set'Access); Thin.Initialize; end if; end Initialize; diff --git a/gcc/ada/g-socthi-mingw.ads b/gcc/ada/g-socthi-mingw.ads index ae4aeea..408d789 100644 --- a/gcc/ada/g-socthi-mingw.ads +++ b/gcc/ada/g-socthi-mingw.ads @@ -121,7 +121,7 @@ package GNAT.Sockets.Thin is function C_Ioctl (S : C.int; Req : C.int; - Arg : Int_Access) return C.int; + Arg : access C.int) return C.int; function C_Listen (S : C.int; diff --git a/gcc/ada/g-socthi-vms.adb b/gcc/ada/g-socthi-vms.adb index 77c61cc..389c256 100644 --- a/gcc/ada/g-socthi-vms.adb +++ b/gcc/ada/g-socthi-vms.adb @@ -73,7 +73,7 @@ package body GNAT.Sockets.Thin is function Syscall_Ioctl (S : C.int; Req : C.int; - Arg : Int_Access) return C.int; + Arg : access C.int) return C.int; pragma Import (C, Syscall_Ioctl, "ioctl"); function Syscall_Recv @@ -148,7 +148,7 @@ package body GNAT.Sockets.Thin is -- tracks sockets set in non-blocking mode by user. 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; return R; @@ -219,7 +219,7 @@ package body GNAT.Sockets.Thin is function C_Ioctl (S : C.int; Req : C.int; - Arg : Int_Access) return C.int + Arg : access C.int) return C.int is begin if not SOSC.Thread_Blocking_IO @@ -361,7 +361,7 @@ package body GNAT.Sockets.Thin is -- Do not use C_Ioctl as this subprogram tracks sockets set -- 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); end if; diff --git a/gcc/ada/g-socthi-vms.ads b/gcc/ada/g-socthi-vms.ads index 47ccf65..dd317bf 100644 --- a/gcc/ada/g-socthi-vms.ads +++ b/gcc/ada/g-socthi-vms.ads @@ -124,7 +124,7 @@ package GNAT.Sockets.Thin is function C_Ioctl (S : C.int; Req : C.int; - Arg : Int_Access) return C.int; + Arg : access C.int) return C.int; function C_Listen (S : C.int; diff --git a/gcc/ada/g-socthi-vxworks.adb b/gcc/ada/g-socthi-vxworks.adb index d9d436f..81a8d96 100644 --- a/gcc/ada/g-socthi-vxworks.adb +++ b/gcc/ada/g-socthi-vxworks.adb @@ -83,7 +83,7 @@ package body GNAT.Sockets.Thin is function Syscall_Ioctl (S : C.int; Req : C.int; - Arg : Int_Access) return C.int; + Arg : access C.int) return C.int; pragma Import (C, Syscall_Ioctl, "ioctl"); function Syscall_Recv @@ -160,7 +160,7 @@ package body GNAT.Sockets.Thin is -- tracks sockets set in non-blocking mode by user. 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 ??? end if; @@ -232,7 +232,7 @@ package body GNAT.Sockets.Thin is function C_Ioctl (S : C.int; Req : C.int; - Arg : Int_Access) return C.int + Arg : access C.int) return C.int is begin if not SOSC.Thread_Blocking_IO @@ -374,7 +374,7 @@ package body GNAT.Sockets.Thin is -- Do not use C_Ioctl as this subprogram tracks sockets set -- 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 ??? Set_Non_Blocking_Socket (R, False); end if; diff --git a/gcc/ada/g-socthi-vxworks.ads b/gcc/ada/g-socthi-vxworks.ads index 5c74e88..06b75e3 100644 --- a/gcc/ada/g-socthi-vxworks.ads +++ b/gcc/ada/g-socthi-vxworks.ads @@ -122,7 +122,7 @@ package GNAT.Sockets.Thin is function C_Ioctl (S : C.int; Req : C.int; - Arg : Int_Access) return C.int; + Arg : access C.int) return C.int; function C_Listen (S : C.int; diff --git a/gcc/ada/g-socthi.adb b/gcc/ada/g-socthi.adb index 289adbe..1062354 100644 --- a/gcc/ada/g-socthi.adb +++ b/gcc/ada/g-socthi.adb @@ -79,7 +79,7 @@ package body GNAT.Sockets.Thin is function Syscall_Ioctl (S : C.int; Req : C.int; - Arg : Int_Access) return C.int; + Arg : access C.int) return C.int; pragma Import (C, Syscall_Ioctl, "ioctl"); function Syscall_Recv @@ -164,7 +164,7 @@ package body GNAT.Sockets.Thin is -- tracks sockets set in non-blocking mode by user. 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; Disable_SIGPIPE (R); @@ -237,7 +237,7 @@ package body GNAT.Sockets.Thin is function C_Ioctl (S : C.int; Req : C.int; - Arg : Int_Access) return C.int + Arg : access C.int) return C.int is begin if not SOSC.Thread_Blocking_IO @@ -379,7 +379,7 @@ package body GNAT.Sockets.Thin is -- Do not use C_Ioctl as this subprogram tracks sockets set -- 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); end if; Disable_SIGPIPE (R); diff --git a/gcc/ada/g-socthi.ads b/gcc/ada/g-socthi.ads index eb11193..8eae6c6 100644 --- a/gcc/ada/g-socthi.ads +++ b/gcc/ada/g-socthi.ads @@ -123,7 +123,7 @@ package GNAT.Sockets.Thin is function C_Ioctl (S : C.int; Req : C.int; - Arg : Int_Access) return C.int; + Arg : access C.int) return C.int; function C_Listen (S : C.int; diff --git a/gcc/ada/g-sothco.ads b/gcc/ada/g-sothco.ads index cb0bc09..5c886b5 100644 --- a/gcc/ada/g-sothco.ads +++ b/gcc/ada/g-sothco.ads @@ -247,14 +247,10 @@ package GNAT.Sockets.Thin_Common is -- 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 (Set : access Fd_Set; - Socket : Int_Access; - Last : Int_Access); + Last : access C.int; + Socket : access C.int); -- Get last socket in Socket and remove it from the socket set. The -- parameter Last is a maximum value of the largest socket. This hint is -- used to avoid scanning very large socket sets. After a call to @@ -274,7 +270,7 @@ package GNAT.Sockets.Thin_Common is procedure Last_Socket_In_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(). -- 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 diff --git a/gcc/ada/gsocket.h b/gcc/ada/gsocket.h index 5d866e0..bbb19da 100644 --- a/gcc/ada/gsocket.h +++ b/gcc/ada/gsocket.h @@ -66,7 +66,7 @@ #include #include #include -#ifndef __RTP__ +#if (_WRS_VXWORKS_MAJOR != 6) && ! defined (__RTP__) #include #endif #define SHUT_RD 0 @@ -176,7 +176,7 @@ #endif -#ifdef __vxworks +#if defined (__vxworks) && ! defined (__RTP__) #include #else #include diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 47fd4e6..0808288 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -2638,14 +2638,36 @@ package body Sem_Ch4 is if Chars (Comp) = Chars (Sel) and then Is_Visible_Component (Comp) 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. + -- AI05-105: if the context is an object renaming with + -- 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; Next_Entity (Comp); diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 0ff2df4..1930c79 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -767,7 +767,46 @@ package body Sem_Ch8 is (Related_Nod => 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 -- access_definition, the renamed entity shall be of an access-to- diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 4adaa56..7535808 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -4831,7 +4831,7 @@ package body Sem_Util is return True; end if; - Comp := Next_Component (Typ); + Next_Component (Comp); end loop; return False; diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index c29c625..5e420c6 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -1004,7 +1004,7 @@ package body Sem_Warn is -- Do not output complaint about never being assigned a -- value if a pragma Unmodified applies to the variable -- we are examining, or if it is a parameter, if there is - -- a pragma Unreferenced for the corresponding spec, of + -- a pragma Unreferenced for the corresponding spec, or -- if the type is marked as having unreferenced objects. -- The last is a little peculiar, but better too few than -- too many warnings in this situation. @@ -1026,7 +1026,7 @@ package body Sem_Warn is -- has a separate declaration in a different unit. This -- is the case where the client of a package sees only -- the private type, and it may be quite reasonable - -- for the logical view to be in out, even if the + -- for the logical view to be IN OUT, even if the -- implementation ends up using access types or some -- other method to achieve the local effect of a -- modification. On the other hand if the spec and body @@ -1050,10 +1050,10 @@ package body Sem_Warn is then null; - -- Suppress warning if composite type containing any - -- access element component, since the logical effect - -- of modifying a parameter may be achieved by modifying - -- a referenced entity. + -- Suppress warning if composite type contains any access + -- component, since the logical effect of modifying a + -- parameter may be achieved by modifying a referenced + -- object. elsif Is_Composite_Type (E1T) and then Has_Access_Values (E1T) @@ -1237,7 +1237,7 @@ package body Sem_Warn is -- If Referenced_As_LHS is set, then that's still interesting -- (potential "assigned but never read" case), but not if we - -- have pragma Unreferenced, which cancels this error. + -- have pragma Unreferenced, which cancels this warning. and then (not Referenced_As_LHS_Check_Spec (E1) or else not Has_Unreferenced (E1)) @@ -1253,13 +1253,13 @@ package body Sem_Warn is (Check_Unreferenced_Formals and then Is_Formal (E1)) -- Case of warning on unread variables modified by an - -- assignment, or an out parameter if it is the only one. + -- assignment, or an OUT parameter if it is the only one. or else (Warn_On_Modified_Unread and then Referenced_As_LHS_Check_Spec (E1)) - -- Case of warning on any unread out parameter (note + -- Case of warning on any unread OUT parameter (note -- such indications are only set if the appropriate -- warning options were set, so no need to recheck here. @@ -1285,11 +1285,11 @@ package body Sem_Warn is or else Is_Overloadable (E1) - -- Package case, if the main unit is a package - -- spec or generic package spec, then there may - -- be a corresponding body that references this - -- package in some other file. Otherwise we can - -- be sure that there is no other reference. + -- Package case, if the main unit is a package spec + -- or generic package spec, then there may be a + -- corresponding body that references this package + -- in some other file. Otherwise we can be sure + -- that there is no other reference. or else (Ekind (E1) = E_Package @@ -1314,7 +1314,7 @@ package body Sem_Warn is and then Referenced (Spec_Entity (E1))) - -- Consider private type referenced if full view is referenced + -- Consider private type referenced if full view is referenced. -- If there is not full view, this is a generic type on which -- warnings are also useful. @@ -1330,7 +1330,7 @@ package body Sem_Warn is -- Eliminate dispatching operations from consideration, we -- cannot tell if these are referenced or not in any easy - -- manner (note this also catches Adjust/Finalize/Initialize) + -- manner (note this also catches Adjust/Finalize/Initialize). and then not Is_Dispatching_Operation (E1) @@ -1356,7 +1356,7 @@ package body Sem_Warn is or else not Is_Task_Type (E1T)) -- For subunits, only place warnings on the main unit itself, - -- since parent units are not completely compiled + -- since parent units are not completely compiled. and then (Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit or else @@ -1372,7 +1372,7 @@ package body Sem_Warn is then -- Suppress warnings in internal units if not in -gnatg mode -- (these would be junk warnings for an applications program, - -- since they refer to problems in internal units) + -- since they refer to problems in internal units). if GNAT_Mode or else not @@ -1425,8 +1425,8 @@ package body Sem_Warn is end if; end if; - -- Recurse into nested package or block. Do not recurse into a - -- formal package, because the corresponding body is not analyzed. + -- Recurse into nested package or block. Do not recurse into a formal + -- package, because the corresponding body is not analyzed. <> if (Is_Package_Or_Generic_Package (E1) @@ -1484,7 +1484,7 @@ package body Sem_Warn is function Prefix_Has_Dereference (Pref : Node_Id) return Boolean is begin - -- If prefix is of an access type, certainly need a dereference + -- If prefix is of an access type, it certainly needs a dereference if Is_Access_Type (Etype (Pref)) then return True; @@ -1526,13 +1526,13 @@ package body Sem_Warn is return; end if; - -- Otherwise see what kind of node we have. If the entity already - -- has an unset reference, it is not necessarily the earliest in - -- the text, because resolution of the prefix of selected components - -- is completed before the resolution of the selected component itself. - -- as a result, given (R /= null and then R.X > 0), the occurrences - -- of R are examined in right-to-left order. If there is already an - -- unset reference, we check whether N is earlier before proceeding. + -- Otherwise see what kind of node we have. If the entity already has an + -- unset reference, it is not necessarily the earliest in the text, + -- because resolution of the prefix of selected components is completed + -- before the resolution of the selected component itself. As a result, + -- given (R /= null and then R.X > 0), the occurrences of R are examined + -- in right-to-left order. If there is already an unset reference, we + -- check whether N is earlier before proceeding. case Nkind (N) is @@ -1560,11 +1560,11 @@ package body Sem_Warn is -- component with default initialization. Both of these -- cases can be ignored, since the actual object that is -- referenced is definitely initialized. Note that this - -- covers the case of reading discriminants of an out + -- covers the case of reading discriminants of an OUT -- parameter, which is OK even in Ada 83. -- Note that we are only interested in a direct reference to - -- a record component here. If the reference is via an + -- a record component here. If the reference is through an -- access type, then the access object is being referenced, -- not the record, and still deserves an unset reference. @@ -1622,9 +1622,9 @@ package body Sem_Warn is SR := Scope (SR); end loop; - -- Case of reference has an access type. This is special - -- case since access types are always set to null so - -- cannot be truly uninitialized, but we still want to + -- Case of reference has an access type. This is a + -- special case since access types are always set to null + -- so cannot be truly uninitialized, but we still want to -- warn about cases of obvious null dereference. if Is_Access_Type (Typ) then @@ -1634,7 +1634,7 @@ package body Sem_Warn is function Process (N : Node_Id) return Traverse_Result; -- Process function for instantiation of Traverse - -- below. Checks if N contains reference to other + -- below. Checks if N contains reference to E other -- than a dereference. function Ref_In (Nod : Node_Id) return Boolean; @@ -1699,7 +1699,7 @@ package body Sem_Warn is end if; -- One more check, don't bother with references - -- that are inside conditional statements or while + -- that are inside conditional statements or WHILE -- loops if the condition references the entity in -- question. This avoids most false positives. @@ -1864,22 +1864,22 @@ package body Sem_Warn is Pack : Entity_Id; procedure Check_Inner_Package (Pack : Entity_Id); - -- Pack is a package local to a unit in a with_clause. Both the - -- unit and Pack are referenced. If none of the entities in Pack - -- are referenced, then the only occurrence of Pack is in a use - -- clause or a pragma, and a warning is worthwhile as well. + -- Pack is a package local to a unit in a with_clause. Both the unit + -- and Pack are referenced. If none of the entities in Pack are + -- referenced, then the only occurrence of Pack is in a USE clause + -- or a pragma, and a warning is worthwhile as well. function Check_System_Aux return Boolean; - -- Before giving a warning on a with_clause for System, check - -- whether a system extension is present. + -- Before giving a warning on a with_clause for System, check wheter + -- a system extension is present. function Find_Package_Renaming (P : Entity_Id; L : Entity_Id) return Entity_Id; -- The only reference to a context unit may be in a renaming - -- declaration. If this renaming declares a visible entity, do - -- not warn that the context clause could be moved to the body, - -- because the renaming may be intended to re-export the unit. + -- declaration. If this renaming declares a visible entity, do not + -- warn that the context clause could be moved to the body, because + -- the renaming may be intended to re-export the unit. ------------------------- -- Check_Inner_Package -- -- 2.7.4