From e7c2522905fe8daa2113c24cfb48ce57e6b2446f Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 14:58:46 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Ed Schonberg * sem_aux.adb (Nearest_Ancestor): Use original node of type declaration to locate nearest ancestor, because derived type declarations for record types are rewritten as record declarations. * sem_ch13.adb (Add_Call): Use an unchecked conversion to handle properly derivations that are completions of private types. (Add_Predicates): If type is private, examine rep. items of full view, which may include inherited predicates. (Build_Predicate_Functions): Ditto. 2017-04-25 Javier Miranda * sem_util.adb (New_Copy_Tree.Visit_Entity): Extend previous change to generate new entities for subtype declarations located in Expression_With_Action nodes. 2017-04-25 Hristian Kirtchev * sem_elab.adb (Check_A_Call): Remove local variables Is_DIC_Proc and Issue_In_SPARK. Verify the need for Elaborate_All when SPARK elaboration checks are required. Update the checks for instances, variables, and calls to Default_Initial_Condition procedures. 2017-04-25 Ed Schonberg * aspects.ads, aspects.adb: Make the GNAT-specific pragma No_Inline into a boolean aspect, in analogy with the Ada aspect No_Return. From-SVN: r247219 --- gcc/ada/ChangeLog | 31 ++++++++++++++++ gcc/ada/aspects.adb | 3 +- gcc/ada/aspects.ads | 5 ++- gcc/ada/sem_aux.adb | 7 ++-- gcc/ada/sem_ch13.adb | 28 ++++++++++++--- gcc/ada/sem_elab.adb | 86 +++++++++++++++++++------------------------- gcc/ada/sem_util.adb | 10 +++--- 7 files changed, 108 insertions(+), 62 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 28499f6c856..158542ccb1f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2017-04-25 Ed Schonberg + + * sem_aux.adb (Nearest_Ancestor): Use original node of type + declaration to locate nearest ancestor, because derived + type declarations for record types are rewritten as record + declarations. + * sem_ch13.adb (Add_Call): Use an unchecked conversion to handle + properly derivations that are completions of private types. + (Add_Predicates): If type is private, examine rep. items of full + view, which may include inherited predicates. + (Build_Predicate_Functions): Ditto. + +2017-04-25 Javier Miranda + + * sem_util.adb (New_Copy_Tree.Visit_Entity): Extend previous change + to generate new entities for subtype declarations located in + Expression_With_Action nodes. + +2017-04-25 Hristian Kirtchev + + * sem_elab.adb (Check_A_Call): Remove + local variables Is_DIC_Proc and Issue_In_SPARK. Verify the + need for Elaborate_All when SPARK elaboration checks are + required. Update the checks for instances, variables, and calls + to Default_Initial_Condition procedures. + +2017-04-25 Ed Schonberg + + * aspects.ads, aspects.adb: Make the GNAT-specific pragma No_Inline + into a boolean aspect, in analogy with the Ada aspect No_Return. + 2017-04-25 Hristian Kirtchev * exp_ch6.adb, sem_ch13.adb, sem_ch6.adb: Minor reformatting. diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb index 49eddf42851..d5ec072d5e7 100644 --- a/gcc/ada/aspects.adb +++ b/gcc/ada/aspects.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2010-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2017, 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- -- @@ -570,6 +570,7 @@ package body Aspects is Aspect_Machine_Radix => Aspect_Machine_Radix, Aspect_Max_Queue_Length => Aspect_Max_Queue_Length, Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All, + Aspect_No_Inline => Aspect_No_Inline, Aspect_No_Return => Aspect_No_Return, Aspect_No_Tagged_Streams => Aspect_No_Tagged_Streams, Aspect_Obsolescent => Aspect_Obsolescent, diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index 586d35fea32..f3c31367d4e 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2010-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 2010-2017, 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- -- @@ -189,6 +189,7 @@ package Aspects is Aspect_Inline_Always, -- GNAT Aspect_Interrupt_Handler, Aspect_Lock_Free, -- GNAT + Aspect_No_Inline, -- GNAT Aspect_No_Return, Aspect_No_Tagged_Streams, -- GNAT Aspect_Pack, @@ -468,6 +469,7 @@ package Aspects is Aspect_Machine_Radix => Name_Machine_Radix, Aspect_Max_Queue_Length => Name_Max_Queue_Length, Aspect_No_Elaboration_Code_All => Name_No_Elaboration_Code_All, + Aspect_No_Inline => Name_No_Inline, Aspect_No_Return => Name_No_Return, Aspect_No_Tagged_Streams => Name_No_Tagged_Streams, Aspect_Object_Size => Name_Object_Size, @@ -677,6 +679,7 @@ package Aspects is Aspect_Link_Name => Always_Delay, Aspect_Linker_Section => Always_Delay, Aspect_Lock_Free => Always_Delay, + Aspect_No_Inline => Always_Delay, Aspect_No_Return => Always_Delay, Aspect_Output => Always_Delay, Aspect_Persistent_BSS => Always_Delay, diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 0ba45981558..1aa22e844e0 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -1295,7 +1295,10 @@ package body Sem_Aux is ---------------------- function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id is - D : constant Node_Id := Declaration_Node (Typ); + D : constant Node_Id := Original_Node (Declaration_Node (Typ)); + -- We use the original node of the declaration, because derived + -- types from record subtypes are rewritten as record declarations, + -- and it is the original declaration that carries the ancestor. begin -- If we have a subtype declaration, get the ancestor subtype diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index add56804197..ea7b3f47e44 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -8309,11 +8309,15 @@ package body Sem_Ch13 is if Present (T) and then Present (Predicate_Function (T)) then Set_Has_Predicates (Typ); - -- Build the call to the predicate function of T + -- Build the call to the predicate function of T. The type may be + -- derived, so use an unchecked conversion for the actual. Exp := Make_Predicate_Call - (T, Convert_To (T, Make_Identifier (Loc, Object_Name))); + (Typ => T, + Expr => + Unchecked_Convert_To (T, + Make_Identifier (Loc, Object_Name))); -- "and"-in the call to evolving expression @@ -8456,6 +8460,14 @@ package body Sem_Ch13 is begin Ritem := First_Rep_Item (Typ); + + -- If the type is private, check whether full view has inherited + -- predicates. + + if Is_Private_Type (Typ) and then No (Ritem) then + Ritem := First_Rep_Item (Full_View (Typ)); + end if; + while Present (Ritem) loop if Nkind (Ritem) = N_Pragma and then Pragma_Name (Ritem) = Name_Predicate @@ -8562,8 +8574,16 @@ package body Sem_Ch13 is -- ones for the current type, as required by AI12-0071-1. declare - Atyp : constant Entity_Id := Nearest_Ancestor (Typ); + Atyp : Entity_Id; begin + Atyp := Nearest_Ancestor (Typ); + + -- The type may be private but the full view may inherit predicates + + if No (Atyp) and then Is_Private_Type (Typ) then + Atyp := Nearest_Ancestor (Full_View (Typ)); + end if; + if Present (Atyp) then Add_Call (Atyp); end if; diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 89b21a0ef6a..b4102edd90e 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2017, 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- -- @@ -629,7 +629,18 @@ package body Sem_Elab is return W_Scope; end Find_W_Scope; - -- Locals + -- Local variables + + Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; + -- Indicates if we have instantiation case + + Loc : constant Source_Ptr := Sloc (N); + + SPARK_Elab_Errors : constant Boolean := + SPARK_Mode = On + and then Dynamic_Elaboration_Checks; + -- Flag set when an entity is called or a variable is read during SPARK + -- dynamic elaboration. Variable_Case : constant Boolean := Nkind (N) in N_Has_Entity @@ -637,10 +648,17 @@ package body Sem_Elab is and then Ekind (Entity (N)) = E_Variable; -- Indicates if we have variable reference case - Loc : constant Source_Ptr := Sloc (N); - - Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation; - -- Indicates if we have instantiation case + W_Scope : constant Entity_Id := Find_W_Scope; + -- Top-level scope of directly called entity for subprogram. This + -- differs from E_Scope in the case where renamings or derivations + -- are involved, since it does not follow these links. W_Scope is + -- generally in a visible unit, and it is this scope that may require + -- an Elaborate_All. However, there are some cases (initialization + -- calls and calls involving object notation) where W_Scope might not + -- be in the context of the current unit, and there is an intermediate + -- package that is, in which case the Elaborate_All has to be placed + -- on this intermediate package. These special cases are handled in + -- Set_Elaboration_Constraint. Ent : Entity_Id; Callee_Unit_Internal : Boolean; @@ -667,26 +685,6 @@ package body Sem_Elab is -- non-visible unit. This is the scope that is to be investigated to -- see whether an elaboration check is required. - Is_DIC_Proc : Boolean := False; - -- Flag set when the call denotes the Default_Initial_Condition - -- procedure of a private type that wraps a nontrivial assertion - -- expression. - - Issue_In_SPARK : Boolean; - -- Flag set when a source entity is called during elaboration in SPARK - - W_Scope : constant Entity_Id := Find_W_Scope; - -- Top-level scope of directly called entity for subprogram. This - -- differs from E_Scope in the case where renamings or derivations - -- are involved, since it does not follow these links. W_Scope is - -- generally in a visible unit, and it is this scope that may require - -- an Elaborate_All. However, there are some cases (initialization - -- calls and calls involving object notation) where W_Scope might not - -- be in the context of the current unit, and there is an intermediate - -- package that is, in which case the Elaborate_All has to be placed - -- on this intermediate package. These special cases are handled in - -- Set_Elaboration_Constraint. - -- Start of processing for Check_A_Call begin @@ -1019,33 +1017,19 @@ package body Sem_Elab is return; end if; - Is_DIC_Proc := Is_Nontrivial_DIC_Procedure (Ent); - - -- Elaboration issues in SPARK are reported only for source constructs - -- and for nontrivial Default_Initial_Condition procedures. The latter - -- must be checked because the default initialization of an object of a - -- private type triggers the evaluation of the Default_Initial_Condition - -- expression, which in turn may have side effects. - - Issue_In_SPARK := - SPARK_Mode = On - and then Dynamic_Elaboration_Checks - and then (Comes_From_Source (Ent) or Is_DIC_Proc); - -- Now check if an Elaborate_All (or dynamic check) is needed - if not Suppress_Elaboration_Warnings (Ent) + if (Elab_Info_Messages or Elab_Warnings or SPARK_Elab_Errors) + and then Generate_Warnings + and then not Suppress_Elaboration_Warnings (Ent) and then not Elaboration_Checks_Suppressed (Ent) and then not Suppress_Elaboration_Warnings (E_Scope) and then not Elaboration_Checks_Suppressed (E_Scope) - and then ((Elab_Warnings or Elab_Info_Messages) - or else SPARK_Mode = On) - and then Generate_Warnings then -- Instantiation case if Inst_Case then - if Issue_In_SPARK then + if Comes_From_Source (Ent) and then SPARK_Elab_Errors then Error_Msg_NE ("instantiation of & during elaboration in SPARK", N, Ent); else @@ -1063,9 +1047,11 @@ package body Sem_Elab is -- Variable reference in SPARK mode - elsif Variable_Case and Issue_In_SPARK then - Error_Msg_NE - ("reference to & during elaboration in SPARK", N, Ent); + elsif Variable_Case then + if Comes_From_Source (Ent) and then SPARK_Elab_Errors then + Error_Msg_NE + ("reference to & during elaboration in SPARK", N, Ent); + end if; -- Subprogram call case @@ -1079,14 +1065,14 @@ package body Sem_Elab is "info: implicit call to & during elaboration?$?", Ent); - elsif Issue_In_SPARK then + elsif SPARK_Elab_Errors then -- Emit a specialized error message when the elaboration of an -- object of a private type evaluates the expression of pragma -- Default_Initial_Condition. This prevents the internal name -- of the procedure from appearing in the error message. - if Is_DIC_Proc then + if Is_Nontrivial_DIC_Procedure (Ent) then Error_Msg_N ("call to Default_Initial_Condition during elaboration in " & "SPARK", N); @@ -1108,7 +1094,7 @@ package body Sem_Elab is -- Case of Elaborate_All not present and required, for SPARK this -- is an error, so give an error message. - if Issue_In_SPARK then + if SPARK_Elab_Errors then Error_Msg_NE -- CODEFIX ("\Elaborate_All pragma required for&", N, W_Scope); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 7f80ba6cb19..42e1601c98d 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, 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- -- @@ -17120,10 +17120,12 @@ package body Sem_Util is pragma Assert (not Is_Itype (Old_Entity)); pragma Assert (Nkind (Old_Entity) in N_Entity); - -- Restrict entity creation to variable declarations. There is no - -- need to create variables declared in inner scopes. + -- Restrict entity creation to declarations of constants, variables + -- and subtypes. There is no need to duplicate entities declared in + -- inner scopes. - if not Ekind_In (Old_Entity, E_Constant, E_Variable) + if (not Ekind_In (Old_Entity, E_Constant, E_Variable) + and then Nkind (Parent (Old_Entity)) /= N_Subtype_Declaration) or else EWA_Inner_Scope_Level > 0 then return; -- 2.30.2