diff options
-rw-r--r-- | gcc/ada/ChangeLog | 31 | ||||
-rw-r--r-- | gcc/ada/a-locale.adb | 9 | ||||
-rw-r--r-- | gcc/ada/a-locale.ads | 11 | ||||
-rw-r--r-- | gcc/ada/inline.adb | 12 | ||||
-rw-r--r-- | gcc/ada/sem_ch13.adb | 12 | ||||
-rw-r--r-- | gcc/ada/sem_ch3.adb | 20 | ||||
-rw-r--r-- | gcc/ada/sem_ch4.adb | 33 | ||||
-rw-r--r-- | gcc/ada/sem_ch5.adb | 8 | ||||
-rw-r--r-- | gcc/ada/sem_res.adb | 5 |
9 files changed, 115 insertions, 26 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 428648a..252efc5 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,36 @@ 2017-01-20 Yannick Moy <moy@adacore.com> + * 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 <schonberg@adacore.com> + + * 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 <obry@adacore.com> + + * a-locale.adb, a-locale.ads: Update Ada.Locales for RM 2012 COR:1:2016 + +2017-01-20 Yannick Moy <moy@adacore.com> + * sem_ch10.adb (Check_No_Elab_Code_All): Do not issue an error on implicitly with'ed units in GNATprove mode. * sinfo.ads (Implicit_With): Document use of flag for implicitly diff --git a/gcc/ada/a-locale.adb b/gcc/ada/a-locale.adb index d56970c..60ad079 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 629f367..132c883 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 9fb47ef..f1afe32 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 55aea49..8f1ce7d 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 68b7323..93b80a8 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 56da406..8ae620c 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 0a72320..6962262 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 3728482..062a839 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; |