mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 17:21:07 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2014-08-04  Olivier Hainque  <hainque@adacore.com>

	* 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  <kirtchev@adacore.com>

	* 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  <schonberg@adacore.com>

	* 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
This commit is contained in:
Arnaud Charlet 2014-08-04 14:53:23 +02:00
parent 51dcceecdf
commit 6a74a7b056
8 changed files with 219 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
gcc/ada/ChangeLog
View File

@ -1,3 +1,31 @@
2014-08-04 Olivier Hainque <hainque@adacore.com>
* 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 <kirtchev@adacore.com>
* 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 <schonberg@adacore.com>
* 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 <kirtchev@adacore.com>
* sem_prag.adb (Analyze_Pragma): Ensure that an

26
gcc/ada/a-comutr.ads
View File

@ -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

14
gcc/ada/exp_ch3.adb
View File

@ -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

7
gcc/ada/exp_ch6.adb
View File

@ -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);

5
gcc/ada/sem_ch3.adb
View File

@ -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.

11
gcc/ada/sem_elab.adb
View File

@ -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

246
gcc/ada/sem_util.adb
View File

@ -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);
-- Replace a single reference to type Typ with a reference to formal
-- parameter Param_Id.
----------------------------
-- Replace_Type_Reference --
----------------------------
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_References is
new Replace_Type_References_Generic (Replace_Type_Reference);
-- Local variables
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;
-- Start of processing for Build_Default_Init_Cond_Procedure
procedure Replace_Type_Reference (N : Node_Id) is
begin
Rewrite (N, New_Occurrence_Of (Param_Id, Sloc (N)));
end Replace_Type_Reference;
-- 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.
procedure Replace_Type_References is
new Replace_Type_References_Generic (Replace_Type_Reference);
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);
-- 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 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, <Expr>);
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;
-- Otherwise the pragma appears without an argument
else
Stmt := Make_Null_Statement (Loc);
end if;
-- Generate:
-- procedure <Typ>Default_Init_Cond (I : <Typ>) is
-- begin
-- <Stmt>;
-- end <Typ>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.
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
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;
Decl : Node_Id;
Typ : Entity_Id;
-- Start of processing for Build_Default_Init_Cond_Procedure
-- Start of processing for Build_Default_Init_Cond_Procedure_Bodies
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.
-- Inspect the private declarations looking for [sub]type declarations
pragma Assert (Has_Default_Init_Cond (Typ));
pragma Assert (Present (Prag));
pragma Assert (Present (Proc_Id));
Decl := First (Priv_Decls);
while Present (Decl) loop
if Nkind_In (Decl, N_Full_Type_Declaration,
N_Subtype_Declaration)
then
Typ := Defining_Entity (Decl);
-- Nothing to do if the body was already built
-- Guard against partially decorate types due to previous errors
if Present (Corresponding_Body (Spec_Decl)) then
return;
end if;
if Is_Type (Typ) then
Param_Id := First_Formal (Proc_Id);
-- 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.
-- The pragma has an argument. Note that the argument is analyzed after
-- all references to the current instance of the type are replaced.
if Has_Default_Init_Cond (Typ) then
Build_Default_Init_Cond_Procedure_Body (Typ);
if Present (Pragma_Argument_Associations (Prag)) then
Expr := Get_Pragma_Arg (First (Pragma_Argument_Associations (Prag)));
-- A derived type inherits the default initial condition
-- procedure from its parent type.
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, <Expr>);
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)));
elsif Has_Inherited_Default_Init_Cond (Typ) then
Inherit_Default_Init_Cond_Procedure (Typ);
end if;
end if;
end if;
-- Otherwise the pragma appears without an argument
else
Stmt := Make_Null_Statement (Loc);
end if;
-- Generate:
-- procedure <Typ>Default_Init_Cond (I : <Typ>) is
-- begin
-- <Stmt>;
-- end <Typ>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;
Next (Decl);
end loop;
end Build_Default_Init_Cond_Procedure_Bodies;
---------------------------------------------------
-- Build_Default_Init_Cond_Procedure_Declaration --

9
gcc/ada/sem_util.ads
View File

@ -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,