From f4ef7b06ce8973846a7002c9325c576e099917d6 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 20 Jan 2017 11:36:01 +0100 Subject: [PATCH] [multiple changes] 2017-01-20 Yannick Moy * inline.adb (Expand_Inlined_Call): Keep more precise type of actual for inlining whenever possible. In particular, do not switch to the formal type in GNATprove mode in some case where the GNAT backend might require it for visibility. 2017-01-20 Ed Schonberg * sem_ch3.adb (Check_Non_Overridable_Aspects): An inherited aspect Implicit_Dereference can be inherited by a full view if the partial view has no discriminants, because there is no way to apply the aspect to the partial view. (Build_Derived_Record_Type): If derived type renames discriminants of the parent, the new discriminant inherits the aspect from the old one. * sem_ch4.adb (Analyze_Call): Handle properly a parameterless call through an access discriminant designating a subprogram. * sem_ch5.adb (Analyze_Assignment): (Analyze_Call): Handle properly a parameterless call through an access discriminant on the left-hand side of an assignment. * sem_res.adb (resolve): If an interpreation involves a discriminant with an implicit dereference and the expression is an entity, resolution takes place later in the appropriate routine. * sem_ch13.adb (Analyze_Aspect_Implicit_Dereference): Recognize access discriminants that designate a subprogram type. 2017-01-20 Pascal Obry * a-locale.adb, a-locale.ads: Update Ada.Locales for RM 2012 COR:1:2016 From-SVN: r244698 --- gcc/ada/ChangeLog | 31 +++++++++++++++++++++++++++++++ gcc/ada/a-locale.adb | 9 ++++----- gcc/ada/a-locale.ads | 11 ++++++++--- gcc/ada/inline.adb | 12 +++++++++++- gcc/ada/sem_ch13.adb | 12 +++++++++--- gcc/ada/sem_ch3.adb | 20 +++++++++++++++----- gcc/ada/sem_ch4.adb | 33 +++++++++++++++++++++++++-------- gcc/ada/sem_ch5.adb | 8 ++++++++ gcc/ada/sem_res.adb | 5 ++++- 9 files changed, 115 insertions(+), 26 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 428648aa862..252efc5079e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2017-01-20 Yannick Moy + + * inline.adb (Expand_Inlined_Call): Keep more + precise type of actual for inlining whenever possible. In + particular, do not switch to the formal type in GNATprove mode in + some case where the GNAT backend might require it for visibility. + +2017-01-20 Ed Schonberg + + * sem_ch3.adb (Check_Non_Overridable_Aspects): An inherited + aspect Implicit_Dereference can be inherited by a full view if + the partial view has no discriminants, because there is no way + to apply the aspect to the partial view. + (Build_Derived_Record_Type): If derived type renames discriminants + of the parent, the new discriminant inherits the aspect from + the old one. + * sem_ch4.adb (Analyze_Call): Handle properly a parameterless + call through an access discriminant designating a subprogram. + * sem_ch5.adb (Analyze_Assignment): (Analyze_Call): Handle + properly a parameterless call through an access discriminant on + the left-hand side of an assignment. + * sem_res.adb (resolve): If an interpreation involves a + discriminant with an implicit dereference and the expression is an + entity, resolution takes place later in the appropriate routine. + * sem_ch13.adb (Analyze_Aspect_Implicit_Dereference): Recognize + access discriminants that designate a subprogram type. + +2017-01-20 Pascal Obry + + * a-locale.adb, a-locale.ads: Update Ada.Locales for RM 2012 COR:1:2016 + 2017-01-20 Yannick Moy * sem_ch10.adb (Check_No_Elab_Code_All): Do not issue an error diff --git a/gcc/ada/a-locale.adb b/gcc/ada/a-locale.adb index d56970c86e9..60ad079d43a 100644 --- a/gcc/ada/a-locale.adb +++ b/gcc/ada/a-locale.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2016, 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- -- @@ -33,8 +33,7 @@ with System; use System; package body Ada.Locales is - type Lower_4 is array (1 .. 4) of Character range 'a' .. 'z'; - type Upper_4 is array (1 .. 4) of Character range 'A' .. 'Z'; + type Str_4 is new String (1 .. 4); -------------- -- Language -- @@ -43,7 +42,7 @@ package body Ada.Locales is function Language return Language_Code is procedure C_Get_Language_Code (P : Address); pragma Import (C, C_Get_Language_Code); - F : Lower_4; + F : Str_4; begin C_Get_Language_Code (F'Address); return Language_Code (F (1 .. 3)); @@ -56,7 +55,7 @@ package body Ada.Locales is function Country return Country_Code is procedure C_Get_Country_Code (P : Address); pragma Import (C, C_Get_Country_Code); - F : Upper_4; + F : Str_4; begin C_Get_Country_Code (F'Address); return Country_Code (F (1 .. 2)); diff --git a/gcc/ada/a-locale.ads b/gcc/ada/a-locale.ads index 629f367bb6c..132c8832b7b 100644 --- a/gcc/ada/a-locale.ads +++ b/gcc/ada/a-locale.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2010, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2016, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. In accordance with the copyright of that document, you can freely -- @@ -19,8 +19,13 @@ package Ada.Locales is pragma Preelaborate (Locales); pragma Remote_Types (Locales); - type Language_Code is array (1 .. 3) of Character range 'a' .. 'z'; - type Country_Code is array (1 .. 2) of Character range 'A' .. 'Z'; + type Language_Code is new String (1 .. 3) + with Dynamic_Predicate => + (for all E of Language_Code => E in 'a' .. 'z'); + + type Country_Code is new String (1 .. 2) + with Dynamic_Predicate => + (for all E of Country_Code => E in 'A' .. 'Z'); Language_Unknown : constant Language_Code := "und"; Country_Unknown : constant Country_Code := "ZZ"; diff --git a/gcc/ada/inline.adb b/gcc/ada/inline.adb index 9fb47ef13cd..f1afe320a3d 100644 --- a/gcc/ada/inline.adb +++ b/gcc/ada/inline.adb @@ -3087,8 +3087,10 @@ package body Inline is elsif Base_Type (Etype (F)) = Base_Type (Etype (A)) and then Etype (F) /= Base_Type (Etype (F)) + and then Is_Constrained (Etype (F)) then Temp_Typ := Etype (F); + else Temp_Typ := Etype (A); end if; @@ -3150,7 +3152,15 @@ package body Inline is Subtype_Mark => New_Occurrence_Of (Etype (F), Loc), Expression => Relocate_Node (Expression (A))); - elsif Etype (F) /= Etype (A) then + -- In GNATprove mode, keep the most precise type of the actual + -- for the temporary variable. Otherwise, the AST may contain + -- unexpected assignment statements to a temporary variable of + -- unconstrained type renaming a local variable of constrained + -- type, which is not expected by GNATprove. + + elsif Etype (F) /= Etype (A) + and then not GNATprove_Mode + then New_A := Unchecked_Convert_To (Etype (F), Relocate_Node (A)); Temp_Typ := Etype (F); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 55aea49bf2f..8f1ce7dba12 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -1808,11 +1808,17 @@ package body Sem_Ch13 is ("aspect must name a discriminant of current type", Expr); else + + -- Discriminant type be an anonymous access type or an + -- anonymous access to subprogram. + -- Missing synchronized types??? + Disc := First_Discriminant (E); while Present (Disc) loop if Chars (Expr) = Chars (Disc) - and then Ekind (Etype (Disc)) = - E_Anonymous_Access_Type + and then Ekind_In (Etype (Disc), + E_Anonymous_Access_Type, + E_Anonymous_Access_Subprogram_Type) then Set_Has_Implicit_Dereference (E); Set_Has_Implicit_Dereference (Disc); @@ -8684,7 +8690,7 @@ package body Sem_Ch13 is Expression => Expr)))); -- If declaration has not been analyzed yet, Insert declaration - -- before freeze node. Insert body itself after freeze node. + -- before freeze node. Insert body itself after freeze node. if not Analyzed (FDecl) then Insert_Before_And_Analyze (N, FDecl); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 68b732398f3..93b80a833b2 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2836,6 +2836,8 @@ package body Sem_Ch3 is then if not Has_Aspect_Spec (Prev_Aspects, Name_Implicit_Dereference) + and then Present + (Discriminant_Specifications (Original_Node (Parent (Prev)))) then Error_Msg_N ("type does not inherit implicit dereference", Prev); @@ -8973,6 +8975,9 @@ package body Sem_Ch3 is -- STEP 5a: Copy the parent record declaration for untagged types + Set_Has_Implicit_Dereference + (Derived_Type, Has_Implicit_Dereference (Parent_Type)); + if not Is_Tagged then -- Discriminant_Constraint (Derived_Type) has been properly @@ -9015,8 +9020,6 @@ package body Sem_Ch3 is Set_Stored_Constraint (Derived_Type, Expand_To_Stored_Constraint (Parent_Type, Discs)); Replace_Components (Derived_Type, New_Decl); - Set_Has_Implicit_Dereference - (Derived_Type, Has_Implicit_Dereference (Parent_Type)); end if; -- Insert the new derived type declaration @@ -9635,12 +9638,19 @@ package body Sem_Ch3 is -- If any of the discriminant constraints is given by a -- discriminant and we are in a derived type declaration we -- have a discriminant renaming. Establish link between new - -- and old discriminant. + -- and old discriminant. The new discriminant has an implicit + -- dereference if the old one does. if Denotes_Discriminant (Discr_Expr (J)) then if Derived_Def then - Set_Corresponding_Discriminant - (Entity (Discr_Expr (J)), Discr); + declare + New_Discr : constant Entity_Id := Entity (Discr_Expr (J)); + + begin + Set_Corresponding_Discriminant (New_Discr, Discr); + Set_Has_Implicit_Dereference (New_Discr, + Has_Implicit_Dereference (Discr)); + end; end if; -- Force the evaluation of non-discriminant expressions. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 56da4061867..8ae620cd144 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -913,6 +913,7 @@ package body Sem_Ch4 is -- the type-checking is similar to that of other calls. procedure Analyze_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); Actuals : constant List_Id := Parameter_Associations (N); Nam : Node_Id; X : Interp_Index; @@ -1310,17 +1311,32 @@ package body Sem_Ch4 is -- If the interpretation succeeds, mark the proper type of the -- prefix (any valid candidate will do). If not, remove the - -- candidate interpretation. This only needs to be done for - -- overloaded protected operations, for other entities disambi- - -- guation is done directly in Resolve. + -- candidate interpretation. If this is a parameterless call + -- on an anonymous access to subprogram, X is a variable with + -- an access discriminant D, the entity in the interpretation is + -- D, so rewrite X as X.D.all. if Success then if Deref and then Nkind (Parent (N)) /= N_Explicit_Dereference then - Set_Entity (Nam, It.Nam); - Insert_Explicit_Dereference (Nam); - Set_Etype (Nam, Nam_Ent); + if Ekind (It.Nam) = E_Discriminant + and then Has_Implicit_Dereference (It.Nam) + then + Rewrite (Name (N), + Make_Explicit_Dereference (Loc, + Prefix => Make_Selected_Component (Loc, + Prefix => + (New_Occurrence_Of (Entity (Nam), Loc)), + Selector_Name => New_Occurrence_Of (It.Nam, Loc)))); + Analyze (N); + return; + + else + Set_Entity (Nam, It.Nam); + Insert_Explicit_Dereference (Nam); + Set_Etype (Nam, Nam_Ent); + end if; else Set_Etype (Nam, It.Typ); @@ -7981,10 +7997,12 @@ package body Sem_Ch4 is if not Is_Overloaded (Func_Name) then Func := Entity (Func_Name); + Indexing := Make_Function_Call (Loc, Name => New_Occurrence_Of (Func, Loc), Parameter_Associations => Assoc); + Set_Parent (Indexing, Parent (N)); Set_Generalized_Indexing (N, Indexing); Analyze (Indexing); @@ -8009,7 +8027,6 @@ package body Sem_Ch4 is Name => Make_Identifier (Loc, Chars (Func_Name)), Parameter_Associations => Assoc); - Set_Parent (Indexing, Parent (N)); Set_Generalized_Indexing (N, Indexing); Set_Etype (N, Any_Type); @@ -8024,7 +8041,7 @@ package body Sem_Ch4 is Get_First_Interp (Func_Name, I, It); Set_Etype (Indexing, Any_Type); - -- Analyze eacn candidae function with the given actuals + -- Analyze each candidate function with the given actuals while Present (It.Nam) loop Analyze_One_Call (Indexing, It.Nam, False, Success); diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index 0a72320ecbb..6962262df18 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -330,6 +330,14 @@ package body Sem_Ch5 is then null; + -- This may be a call to a parameterless function through an + -- implicit dereference, so discard interpretation as well. + + elsif Is_Entity_Name (Lhs) + and then Has_Implicit_Dereference (It.Typ) + then + null; + elsif Has_Compatible_Type (Rhs, It.Typ) then if T1 /= Any_Type then diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 3728482a151..062a8392f9a 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2469,6 +2469,7 @@ package body Sem_Res is N_Attribute_Reference, N_And_Then, N_Indexed_Component, + N_Identifier, N_Or_Else, N_Range, N_Selected_Component, @@ -2626,7 +2627,9 @@ package body Sem_Res is -- replaced by the appropriate call during late -- expansion. - if not Box_Present (Elmt) then + if Nkind (Elmt) /= N_Iterated_Component_Association + and then not Box_Present (Elmt) + then Check_Elmt (Expression (Elmt)); end if; -- 2.30.2