From 6a74a7b056cc46079cd4146f25ee22708f473ac5 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 4 Aug 2014 14:53:23 +0200 Subject: [PATCH] [multiple changes] 2014-08-04 Olivier Hainque * a-comutr.ads: Set Root_Node_Type'Alignment to Standard'Maximum_Alignment, so that it is at least as large as the max default for Tree_Node_Type'Alignment. 2014-08-04 Hristian Kirtchev * exp_ch3.adb (Freeze_Type): Remove the generation and inheritance of the default initial condition procedure [body]. * sem_ch3.adb (Analyze_Declarations): Create the bodies of all default initial condition procedures at the end of private declaration analysis. * sem_util.adb (Build_Default_Init_Cond_Procedure_Bodies): New routine. (Build_Default_Init_Cond_Procedure_Body): Merged in the processing of routine Build_Default_Init_Cond_Procedure_Bodies. * sem_util.ads (Build_Default_Init_Cond_Procedure_Bodies): New routine. (Build_Default_Init_Cond_Procedure_Body): Removed. 2014-08-04 Ed Schonberg * sem_elab.adb (Check_Elab_Call): Do not check a call to a postcondtion. * exp_ch6.adb (Expand_Call): Clarify handling of inserted postcondition call. From-SVN: r213580 --- gcc/ada/ChangeLog | 28 +++++ gcc/ada/a-comutr.ads | 26 +++-- gcc/ada/exp_ch3.adb | 14 --- gcc/ada/exp_ch6.adb | 7 ++ gcc/ada/sem_ch3.adb | 5 +- gcc/ada/sem_elab.adb | 11 ++ gcc/ada/sem_util.adb | 242 ++++++++++++++++++++++++++----------------- gcc/ada/sem_util.ads | 9 +- 8 files changed, 217 insertions(+), 125 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 02b59b2bc4c..49127ff21ba 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,31 @@ +2014-08-04 Olivier Hainque + + * a-comutr.ads: Set Root_Node_Type'Alignment to + Standard'Maximum_Alignment, so that it is at least as large as + the max default for Tree_Node_Type'Alignment. + +2014-08-04 Hristian Kirtchev + + * exp_ch3.adb (Freeze_Type): Remove the generation and inheritance + of the default initial condition procedure [body]. + * sem_ch3.adb (Analyze_Declarations): Create the bodies of + all default initial condition procedures at the end of private + declaration analysis. + * sem_util.adb (Build_Default_Init_Cond_Procedure_Bodies): New + routine. + (Build_Default_Init_Cond_Procedure_Body): Merged in the + processing of routine Build_Default_Init_Cond_Procedure_Bodies. + * sem_util.ads (Build_Default_Init_Cond_Procedure_Bodies): + New routine. + (Build_Default_Init_Cond_Procedure_Body): Removed. + +2014-08-04 Ed Schonberg + + * sem_elab.adb (Check_Elab_Call): Do not check a call to a + postcondtion. + * exp_ch6.adb (Expand_Call): Clarify handling of inserted + postcondition call. + 2014-08-04 Hristian Kirtchev * sem_prag.adb (Analyze_Pragma): Ensure that an diff --git a/gcc/ada/a-comutr.ads b/gcc/ada/a-comutr.ads index 6e0aa9a1203..c1a3dc85cd5 100644 --- a/gcc/ada/a-comutr.ads +++ b/gcc/ada/a-comutr.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 2004-2012, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- -- -- -- This specification is derived from the Ada Reference Manual for use with -- -- GNAT. The copyright notice above, and the license provisions that follow -- @@ -308,17 +308,16 @@ package Ada.Containers.Multiway_Trees is Process : not null access procedure (Position : Cursor)); private - -- A node of this multiway tree comprises an element and a list of children -- (that are themselves trees). The root node is distinguished because it -- contains only children: it does not have an element itself. - -- - -- This design feature puts two design goals in tension: + + -- This design feature puts two design goals in tension with one another: -- (1) treat the root node the same as any other node -- (2) not declare any objects of type Element_Type unnecessarily - -- - -- To satisfy (1), we could simply declare the Root node of the tree using - -- the normal Tree_Node_Type, but that would mean that (2) is not + + -- To satisfy (1), we could simply declare the Root node of the tree + -- using the normal Tree_Node_Type, but that would mean that (2) is not -- satisfied. To resolve the tension (in favor of (2)), we declare the -- component Root as having a different node type, without an Element -- component (thus satisfying goal (2)) but otherwise identical to a normal @@ -327,11 +326,11 @@ private -- normal, non-root node (thus satisfying goal (1)). We make an explicit -- check for Root when there is any attempt to manipulate the Element -- component of the node (a check required by the RM anyway). - -- + -- In order to be explicit about node (and pointer) representation, we - -- specify that the respective node types have convention C, to ensure that - -- the layout of the components of the node records is the same, thus - -- guaranteeing that (unchecked) conversions between access types + -- specify that the respective node types have convention C, to ensure + -- that the layout of the components of the node records is the same, + -- thus guaranteeing that (unchecked) conversions between access types -- designating each kind of node type is a meaningful conversion. type Tree_Node_Type; @@ -366,6 +365,11 @@ private end record; pragma Convention (C, Root_Node_Type); + for Root_Node_Type'Alignment use Standard'Maximum_Alignment; + -- The alignment has to be large enough to allow Root_Node to Tree_Node + -- access value conversions, and Tree_Node_Type's alignment may be bumped + -- up by the Element component. + use Ada.Finalization; -- The Count component of type Tree represents the number of nodes that diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 6eec78a4732..5e11962325c 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -7394,20 +7394,6 @@ package body Exp_Ch3 is end if; end if; - -- If the type is subject to pragma Default_Initial_Condition, generate - -- the body of the procedure which verifies the assertion of the pragma - -- at runtime. - - if Has_Default_Init_Cond (Def_Id) then - Build_Default_Init_Cond_Procedure_Body (Def_Id); - - -- A derived type inherits the default initial condition procedure from - -- its parent type. - - elsif Has_Inherited_Default_Init_Cond (Def_Id) then - Inherit_Default_Init_Cond_Procedure (Def_Id); - end if; - -- Freeze processing for record types if Is_Record_Type (Def_Id) then diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 7f111901b05..82c87871f87 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -5209,6 +5209,13 @@ package body Exp_Ch6 is -- Analyze call, but something goes wrong in some weird cases -- and it is not worth worrying about ??? + -- The return statement is handled properly, and the call to + -- the postcondition, inserted below, does not require + -- information from the body either. However, that call is + -- analyzed in the enclosing scope, and an elaboration check + -- might improperly be added to it. A guard in sem_elab is + -- needed to prevent that spurious check, see Check_Elab_Call. + Append_To (S, Rtn); Set_Analyzed (Rtn); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 424cc696bfb..5b16aa2477a 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2388,10 +2388,13 @@ package body Sem_Ch3 is -- When a package has private declarations, its contract must be -- analyzed at the end of the said declarations. This way both the -- analysis and freeze actions are properly synchronized in case - -- of private type use within the contract. + -- of private type use within the contract. Build the bodies of + -- the default initial condition procedures for all types subject + -- to pragma Default_Initial_Condition. if L = Private_Declarations (Context) then Analyze_Package_Contract (Defining_Entity (Context)); + Build_Default_Init_Cond_Procedure_Bodies (L); -- Otherwise the contract is analyzed at the end of the visible -- declarations. diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 296c2a2340f..e5e29bcce21 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -1218,6 +1218,17 @@ package body Sem_Elab is return; end if; + -- Nothing to do if this is a call to a postcondition, which is always + -- within a subprogram body, even though the current scope may be the + -- enclosing scope of the subprogram. + + if Nkind (N) = N_Procedure_Call_Statement + and then Is_Entity_Name (Name (N)) + and then Chars (Entity (Name (N))) = Name_uPostconditions + then + return; + end if; + -- Here we have a call at elaboration time which must be checked if Debug_Flag_LL then diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 71a6429703b..d55d7c5f63f 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1252,123 +1252,177 @@ package body Sem_Util is Expression => New_Occurrence_Of (Obj_Id, Loc)))); end Build_Default_Init_Cond_Call; - -------------------------------------------- - -- Build_Default_Init_Cond_Procedure_Body -- - -------------------------------------------- + ---------------------------------------------- + -- Build_Default_Init_Cond_Procedure_Bodies -- + ---------------------------------------------- - procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id) is - Param_Id : Entity_Id; - -- The entity of the formal parameter of the default initial condition - -- procedure. + procedure Build_Default_Init_Cond_Procedure_Bodies (Priv_Decls : List_Id) is + procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id); + -- If type Typ is subject to pragma Default_Initial_Condition, build the + -- body of the procedure which verifies the assumption of the pragma at + -- runtime. The generated body is added after the type declaration. - procedure Replace_Type_Reference (N : Node_Id); - -- Replace a single reference to type Typ with a reference to Param_Id + -------------------------------------------- + -- Build_Default_Init_Cond_Procedure_Body -- + -------------------------------------------- - ---------------------------- - -- Replace_Type_Reference -- - ---------------------------- + procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id) is + Param_Id : Entity_Id; + -- The entity of the sole formal parameter of the default initial + -- condition procedure. - procedure Replace_Type_Reference (N : Node_Id) is - begin - Rewrite (N, New_Occurrence_Of (Param_Id, Sloc (N))); - end Replace_Type_Reference; + procedure Replace_Type_Reference (N : Node_Id); + -- Replace a single reference to type Typ with a reference to formal + -- parameter Param_Id. - procedure Replace_Type_References is - new Replace_Type_References_Generic (Replace_Type_Reference); + ---------------------------- + -- Replace_Type_Reference -- + ---------------------------- - -- Local variables + procedure Replace_Type_Reference (N : Node_Id) is + begin + Rewrite (N, New_Occurrence_Of (Param_Id, Sloc (N))); + end Replace_Type_Reference; - Loc : constant Source_Ptr := Sloc (Typ); - Prag : constant Node_Id := - Get_Pragma (Typ, Pragma_Default_Initial_Condition); - Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ); - Spec_Decl : constant Node_Id := Unit_Declaration_Node (Proc_Id); - Body_Decl : Node_Id; - Expr : Node_Id; - Stmt : Node_Id; + procedure Replace_Type_References is + new Replace_Type_References_Generic (Replace_Type_Reference); - -- Start of processing for Build_Default_Init_Cond_Procedure + -- Local variables - begin - -- The procedure should be generated only for types subject to pragma - -- Default_Initial_Condition. Types that inherit the pragma do not get - -- this specialized procedure. + Loc : constant Source_Ptr := Sloc (Typ); + Prag : constant Node_Id := + Get_Pragma (Typ, Pragma_Default_Initial_Condition); + Proc_Id : constant Entity_Id := Default_Init_Cond_Procedure (Typ); + Spec_Decl : constant Node_Id := Unit_Declaration_Node (Proc_Id); + Body_Decl : Node_Id; + Expr : Node_Id; + Stmt : Node_Id; - pragma Assert (Has_Default_Init_Cond (Typ)); - pragma Assert (Present (Prag)); - pragma Assert (Present (Proc_Id)); + -- Start of processing for Build_Default_Init_Cond_Procedure - -- Nothing to do if the body was already built + begin + -- The procedure should be generated only for [sub]types subject to + -- pragma Default_Initial_Condition. Types that inherit the pragma do + -- not get this specialized procedure. - if Present (Corresponding_Body (Spec_Decl)) then - return; - end if; + pragma Assert (Has_Default_Init_Cond (Typ)); + pragma Assert (Present (Prag)); + pragma Assert (Present (Proc_Id)); + + -- Nothing to do if the body was already built + + if Present (Corresponding_Body (Spec_Decl)) then + return; + end if; - Param_Id := First_Formal (Proc_Id); + Param_Id := First_Formal (Proc_Id); - -- The pragma has an argument. Note that the argument is analyzed after - -- all references to the current instance of the type are replaced. + -- The pragma has an argument. Note that the argument is analyzed + -- after all references to the current instance of the type are + -- replaced. - if Present (Pragma_Argument_Associations (Prag)) then - Expr := Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); + if Present (Pragma_Argument_Associations (Prag)) then + Expr := + Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag))); - if Nkind (Expr) = N_Null then - Stmt := Make_Null_Statement (Loc); + if Nkind (Expr) = N_Null then + Stmt := Make_Null_Statement (Loc); + + -- Preserve the original argument of the pragma by replicating it. + -- Replace all references to the current instance of the type with + -- references to the formal parameter. + + else + Expr := New_Copy_Tree (Expr); + Replace_Type_References (Expr, Typ); + + -- Generate: + -- pragma Check (Default_Initial_Condition, ); + + Stmt := + Make_Pragma (Loc, + Pragma_Identifier => + Make_Identifier (Loc, Name_Check), + + Pragma_Argument_Associations => New_List ( + Make_Pragma_Argument_Association (Loc, + Expression => + Make_Identifier (Loc, + Chars => Name_Default_Initial_Condition)), + Make_Pragma_Argument_Association (Loc, + Expression => Expr))); + end if; - -- Preserve the original argument of the pragma by replicating it. - -- Replace all references to the current instance of the type with - -- references to the formal parameter. + -- Otherwise the pragma appears without an argument else - Expr := New_Copy_Tree (Expr); - Replace_Type_References (Expr, Typ); - - -- Generate: - -- pragma Check (Default_Initial_Condition, ); - - Stmt := - Make_Pragma (Loc, - Pragma_Identifier => - Make_Identifier (Loc, Name_Check), - - Pragma_Argument_Associations => New_List ( - Make_Pragma_Argument_Association (Loc, - Expression => - Make_Identifier (Loc, Name_Default_Initial_Condition)), - Make_Pragma_Argument_Association (Loc, - Expression => Expr))); + Stmt := Make_Null_Statement (Loc); end if; - -- Otherwise the pragma appears without an argument + -- Generate: + -- procedure Default_Init_Cond (I : ) is + -- begin + -- ; + -- end Default_Init_Cond; - else - Stmt := Make_Null_Statement (Loc); - end if; + Body_Decl := + Make_Subprogram_Body (Loc, + Specification => + Copy_Separate_Tree (Specification (Spec_Decl)), + Declarations => Empty_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Stmt))); - -- Generate: - -- procedure Default_Init_Cond (I : ) is - -- begin - -- ; - -- end Default_Init_Cond; - - Body_Decl := - Make_Subprogram_Body (Loc, - Specification => - Copy_Separate_Tree (Specification (Spec_Decl)), - Declarations => Empty_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Stmt))); - - -- Link the spec and body of the default initial condition procedure - -- to prevent the generation of a duplicate body in case there is an - -- attempt to freeze the related type again. - - Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl)); - Set_Corresponding_Spec (Body_Decl, Proc_Id); - - Append_Freeze_Action (Typ, Body_Decl); - end Build_Default_Init_Cond_Procedure_Body; + -- Link the spec and body of the default initial condition procedure + -- to prevent the generation of a duplicate body. + + Set_Corresponding_Body (Spec_Decl, Defining_Entity (Body_Decl)); + Set_Corresponding_Spec (Body_Decl, Proc_Id); + + Insert_After_And_Analyze (Declaration_Node (Typ), Body_Decl); + end Build_Default_Init_Cond_Procedure_Body; + + -- Local variables + + Decl : Node_Id; + Typ : Entity_Id; + + -- Start of processing for Build_Default_Init_Cond_Procedure_Bodies + + begin + -- Inspect the private declarations looking for [sub]type declarations + + Decl := First (Priv_Decls); + while Present (Decl) loop + if Nkind_In (Decl, N_Full_Type_Declaration, + N_Subtype_Declaration) + then + Typ := Defining_Entity (Decl); + + -- Guard against partially decorate types due to previous errors + + if Is_Type (Typ) then + + -- If the type is subject to pragma Default_Initial_Condition, + -- generate the body of the internal procedure which verifies + -- the assertion of the pragma at runtime. + + if Has_Default_Init_Cond (Typ) then + Build_Default_Init_Cond_Procedure_Body (Typ); + + -- A derived type inherits the default initial condition + -- procedure from its parent type. + + elsif Has_Inherited_Default_Init_Cond (Typ) then + Inherit_Default_Init_Cond_Procedure (Typ); + end if; + end if; + end if; + + Next (Decl); + end loop; + end Build_Default_Init_Cond_Procedure_Bodies; --------------------------------------------------- -- Build_Default_Init_Cond_Procedure_Declaration -- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b567e43d6fc..2892916c757 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -218,11 +218,10 @@ package Sem_Util is -- Build a call to the default initial condition procedure of type Typ with -- Obj_Id as the actual parameter. - procedure Build_Default_Init_Cond_Procedure_Body (Typ : Entity_Id); - -- If private type Typ is subject to pragma Default_Initial_Condition, - -- build the body of the procedure which verifies the assumption of the - -- pragma at runtime. The generated body is added to the freeze actions - -- of the type. + procedure Build_Default_Init_Cond_Procedure_Bodies (Priv_Decls : List_Id); + -- Inspect the contents of private declarations Priv_Decls and build the + -- bodies the default initial condition procedures for all types subject + -- to pragma Default_Initial_Condition. procedure Build_Default_Init_Cond_Procedure_Declaration (Typ : Entity_Id); -- If private type Typ is subject to pragma Default_Initial_Condition, -- 2.30.2