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

[multiple changes]

Browse Source 
2013-01-03  Thomas Quinot  <quinot@adacore.com>

	* exp_ch11.adb: Minor reformatting.

2013-01-03  Thomas Quinot  <quinot@adacore.com>

	* exp_util.adb, einfo.adb, einfo.ads, freeze.adb, exp_aggr.adb,
	sem_ch13.adb (Einfo.Initialization_Statements,
	Einfo.Set_Initialization_Statements): New entity attribute
	for objects.
	(Exp_Util.Find_Init_Call): Handle case of an object initialized
	by an aggregate converted to a block of assignment statements.
	(Freeze.Check_Address_Clause): Do not clear Has_Delayed_Freeze
	even for objects that require a constant address, because the
	address expression might involve entities that have yet to be
	elaborated at the point of the object declaration.
	(Exp_Aggr.Convert_Aggregate_In_Obj_Decl): For a type that does
	not require a transient scope, capture the assignment statements
	in a block so that they can be moved down after elaboration of
	an address clause if needed.
	(Sem_Ch13.Check_Constant_Address_Clause.Check_Expr_Constants,
	case N_Unchecked_Conversion): Do not replace operand subtype with
	its base type as this violates a GIGI invariant if the operand
	is an identifier (in which case the etype of the identifier
	is expected to be equal to that of the denoted entity).

2013-01-03  Javier Miranda  <miranda@adacore.com>

	* sem_util.ads, sem_util.adb (Denotes_Same_Object): Extend the
	functionality of this routine to cover cases described in the Ada 2012
	reference manual.

2013-01-03  Ed Schonberg  <schonberg@adacore.com>

	* sem_elab.adb (Set_Elaboration_Constraint): Handle properly
	a 'Access attribute reference when the subprogram is called
	Initialize.

2013-01-03  Arnaud Charlet  <charlet@adacore.com>

	* s-tpobop.adb (PO_Do_Or_Queue): Refine assertion, since a
	select statement may be called from a controlled (e.g. Initialize)
	operation and have abort always deferred.

From-SVN: r194847
This commit is contained in:
Arnaud Charlet 2013-01-03 11:58:47 +01:00
parent 8398e82ecc
commit 02217452f0
12 changed files with 267 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
gcc/ada/ChangeLog
View File

@ -1,3 +1,47 @@
2013-01-03 Thomas Quinot <quinot@adacore.com>
* exp_ch11.adb: Minor reformatting.
2013-01-03 Thomas Quinot <quinot@adacore.com>
* exp_util.adb, einfo.adb, einfo.ads, freeze.adb, exp_aggr.adb,
sem_ch13.adb (Einfo.Initialization_Statements,
Einfo.Set_Initialization_Statements): New entity attribute
for objects.
(Exp_Util.Find_Init_Call): Handle case of an object initialized
by an aggregate converted to a block of assignment statements.
(Freeze.Check_Address_Clause): Do not clear Has_Delayed_Freeze
even for objects that require a constant address, because the
address expression might involve entities that have yet to be
elaborated at the point of the object declaration.
(Exp_Aggr.Convert_Aggregate_In_Obj_Decl): For a type that does
not require a transient scope, capture the assignment statements
in a block so that they can be moved down after elaboration of
an address clause if needed.
(Sem_Ch13.Check_Constant_Address_Clause.Check_Expr_Constants,
case N_Unchecked_Conversion): Do not replace operand subtype with
its base type as this violates a GIGI invariant if the operand
is an identifier (in which case the etype of the identifier
is expected to be equal to that of the denoted entity).
2013-01-03 Javier Miranda <miranda@adacore.com>
* sem_util.ads, sem_util.adb (Denotes_Same_Object): Extend the
functionality of this routine to cover cases described in the Ada 2012
reference manual.
2013-01-03 Ed Schonberg <schonberg@adacore.com>
* sem_elab.adb (Set_Elaboration_Constraint): Handle properly
a 'Access attribute reference when the subprogram is called
Initialize.
2013-01-03 Arnaud Charlet <charlet@adacore.com>
* s-tpobop.adb (PO_Do_Or_Queue): Refine assertion, since a
select statement may be called from a controlled (e.g. Initialize)
operation and have abort always deferred.
2013-01-03 Robert Dewar <dewar@adacore.com>
* sem_ch8.adb, einfo.ads, einfo.adb: Minor code reorganization.

16
gcc/ada/einfo.adb
View File

@ -237,6 +237,7 @@ package body Einfo is
-- Wrapped_Entity Node27
-- Extra_Formals Node28
-- Initialization_Statements Node28
-- Underlying_Record_View Node28
-- Subprograms_For_Type Node29
@ -1655,6 +1656,12 @@ package body Einfo is
return Flag8 (Id);
end In_Use;
function Initialization_Statements (Id : E) return N is
begin
pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
return Node28 (Id);
end Initialization_Statements;
function Inner_Instances (Id : E) return L is
begin
return Elist23 (Id);
@ -4187,6 +4194,12 @@ package body Einfo is
Set_Flag8 (Id, V);
end Set_In_Use;
procedure Set_Initialization_Statements (Id : E; V : N) is
begin
pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
Set_Node28 (Id, V);
end Set_Initialization_Statements;
procedure Set_Inner_Instances (Id : E; V : L) is
begin
Set_Elist23 (Id, V);
@ -8702,6 +8715,9 @@ package body Einfo is
E_Subprogram_Type =>
Write_Str ("Extra_Formals");
when E_Constant | E_Variable =>
Write_Str ("Initialization_Statements");
when E_Record_Type =>
Write_Str ("Underlying_Record_View");

10
gcc/ada/einfo.ads
View File

@ -1932,6 +1932,12 @@ package Einfo is
-- the end of the package declaration. For objects it indicates that the
-- declaration of the object occurs in the private part of a package.
-- Initialization_Statements (Node28)
-- Defined in constants and variables. For a composite object initialized
-- initialized with an aggregate that has been converted to a sequence
-- of assignments, points to a block statement containing the
-- assignments.
-- Inner_Instances (Elist23)
-- Defined in generic units. Contains element list of units that are
-- instantiated within the given generic. Used to diagnose circular
@ -5104,6 +5110,7 @@ package Einfo is
-- Prival_Link (Node20) (privals only)
-- Interface_Name (Node21) (constants only)
-- Related_Type (Node27) (constants only)
-- Initialization_Statements (Node28)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
@ -5773,6 +5780,7 @@ package Einfo is
-- Debug_Renaming_Link (Node25)
-- Last_Assignment (Node26)
-- Related_Type (Node27)
-- Initialization_Statements (Node28)
-- Has_Alignment_Clause (Flag46)
-- Has_Atomic_Components (Flag86)
-- Has_Biased_Representation (Flag139)
@ -6217,6 +6225,7 @@ package Einfo is
function In_Package_Body (Id : E) return B;
function In_Private_Part (Id : E) return B;
function In_Use (Id : E) return B;
function Initialization_Statements (Id : E) return N;
function Inner_Instances (Id : E) return L;
function Interface_Alias (Id : E) return E;
function Interface_Name (Id : E) return N;
@ -6809,6 +6818,7 @@ package Einfo is
procedure Set_In_Package_Body (Id : E; V : B := True);
procedure Set_In_Private_Part (Id : E; V : B := True);
procedure Set_In_Use (Id : E; V : B := True);
procedure Set_Initialization_Statements (Id : E; V : N);
procedure Set_Inner_Instances (Id : E; V : L);
procedure Set_Interface_Alias (Id : E; V : E);
procedure Set_Interface_Name (Id : E; V : N);

22
gcc/ada/exp_aggr.adb
View File

@ -3012,6 +3012,8 @@ package body Exp_Aggr is
Loc : constant Source_Ptr := Sloc (Aggr);
Typ : constant Entity_Id := Etype (Aggr);
Occ : constant Node_Id := New_Occurrence_Of (Obj, Loc);
Blk : Node_Id := Empty;
Ins : Node_Id;
function Discriminants_Ok return Boolean;
-- If the object type is constrained, the discriminants in the
@ -3116,9 +3118,27 @@ package body Exp_Aggr is
(Aggr,
Sec_Stack =>
Is_Controlled (Typ) or else Has_Controlled_Component (Typ));
Ins := N;
-- Need to Set_Initialization_Statements??? (see below)
else
-- Capture initialization statements within an identified block
-- statement, as we might need to move them to the freeze actions
-- of Obj later on if a representation clause (such as an address
-- clause) makes it necessary to delay freezing.
Ins := Make_Null_Statement (Loc);
Blk := Make_Block_Statement (Loc,
Declarations => New_List,
Handled_Statement_Sequence =>
Make_Handled_Sequence_Of_Statements (Loc,
Statements => New_List (Ins)));
Insert_Action_After (N, Blk);
Set_Initialization_Statements (Obj, Blk);
end if;
Insert_Actions_After (N, Late_Expansion (Aggr, Typ, Occ));
Insert_Actions_After (Ins, Late_Expansion (Aggr, Typ, Occ));
Set_No_Initialization (N);
Initialize_Discriminants (N, Typ);
end Convert_Aggr_In_Object_Decl;

2
gcc/ada/exp_ch11.adb
View File

@ -1832,7 +1832,7 @@ package body Exp_Ch11 is
Rewrite (N,
Make_Attribute_Reference (Loc,
Prefix => Identifier (N),
Prefix => Identifier (N),
Attribute_Name => Name_Code_Address));
Analyze_And_Resolve (N, RTE (RE_Code_Loc));

9
gcc/ada/exp_util.adb
View File

@ -2206,13 +2206,20 @@ package body Exp_Util is
-- Start of processing for Find_Init_Call
begin
if not Has_Non_Null_Base_Init_Proc (Typ) then
if Present (Initialization_Statements (Var)) then
return Initialization_Statements (Var);
elsif not Has_Non_Null_Base_Init_Proc (Typ) then
-- No init proc for the type, so obviously no call to be found
return Empty;
end if;
-- We might be able to handle other cases below by just properly setting
-- Initialization_Statements at the point where the init proc call is
-- generated???
Init_Proc := Base_Init_Proc (Typ);
-- First scan the list containing the declaration of Var

9
gcc/ada/freeze.adb
View File

@ -562,12 +562,9 @@ package body Freeze is
Check_Constant_Address_Clause (Expr, E);
-- Has_Delayed_Freeze was set on E when the address clause was
-- analyzed. Reset the flag now unless freeze actions were
-- attached to it in the mean time.
if No (Freeze_Node (E)) then
Set_Has_Delayed_Freeze (E, False);
end if;
-- analyzed, and must remain set because we want the address
-- clause to be elaborated only after any entity it references
-- has been elaborated.
end if;
-- If Rep_Clauses are to be ignored, remove address clause from

4
gcc/ada/s-tpobop.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1998-2012, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -379,7 +379,7 @@ package body System.Tasking.Protected_Objects.Operations is
end if;
STPO.Write_Lock (Entry_Call.Self);
pragma Assert (Entry_Call.State >= Was_Abortable);
pragma Assert (Entry_Call.State /= Not_Yet_Abortable);
Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);
STPO.Unlock (Entry_Call.Self);

26
gcc/ada/sem_ch13.adb
View File

@ -2880,7 +2880,9 @@ package body Sem_Ch13 is
-- Legality checks on the address clause for initialized
-- objects is deferred until the freeze point, because
-- a subsequent pragma might indicate that the object
-- is imported and thus not initialized.
-- is imported and thus not initialized. Also, the address
-- clause might involve entities that have yet to be
-- elaborated.
Set_Has_Delayed_Freeze (U_Ent);
@ -7216,28 +7218,10 @@ package body Sem_Ch13 is
when N_Type_Conversion |
N_Qualified_Expression |
N_Allocator =>
N_Allocator |
N_Unchecked_Type_Conversion =>
Check_Expr_Constants (Expression (Nod));
when N_Unchecked_Type_Conversion =>
Check_Expr_Constants (Expression (Nod));
-- If this is a rewritten unchecked conversion, subtypes in
-- this node are those created within the instance. To avoid
-- order of elaboration issues, replace them with their base
-- types. Note that address clauses can cause order of
-- elaboration problems because they are elaborated by the
-- back-end at the point of definition, and may mention
-- entities declared in between (as long as everything is
-- static). It is user-friendly to allow unchecked conversions
-- in this context.
if Nkind (Original_Node (Nod)) = N_Function_Call then
Set_Etype (Expression (Nod),
Base_Type (Etype (Expression (Nod))));
Set_Etype (Nod, Base_Type (Etype (Nod)));
end if;
when N_Function_Call =>
if not Is_Pure (Entity (Name (Nod))) then
Error_Msg_NE

8
gcc/ada/sem_elab.adb
View File

@ -2541,8 +2541,14 @@ package body Sem_Elab is
Scop : Entity_Id)
is
Elab_Unit : Entity_Id;
-- Check whether this is a call to an Initialize subprogram for a
-- controlled type. Note that Call can also be a 'access attribute
-- reference, which now generates an elaboration check.
Init_Call : constant Boolean :=
Chars (Subp) = Name_Initialize
Nkind (Call) = N_Procedure_Call_Statement
and then Chars (Subp) = Name_Initialize
and then Comes_From_Source (Subp)
and then Present (Parameter_Associations (Call))
and then Is_Controlled (Etype (First_Actual (Call)));

192
gcc/ada/sem_util.adb
View File

@ -2814,87 +2814,188 @@ package body Sem_Util is
Obj1 : Node_Id := A1;
Obj2 : Node_Id := A2;
procedure Check_Renaming (Obj : in out Node_Id);
-- If an object is a renaming, examine renamed object. If it is a
-- dereference of a variable, or an indexed expression with non-constant
-- indexes, no overlap check can be reported.
function Has_Prefix (N : Node_Id) return Boolean;
-- Return True if N has attribute Prefix
--------------------
-- Check_Renaming --
--------------------
function Is_Renaming (N : Node_Id) return Boolean;
-- Return true if N names a renaming entity
procedure Check_Renaming (Obj : in out Node_Id) is
function Is_Valid_Renaming (N : Node_Id) return Boolean;
-- For renamings, return False if the prefix of any dereference within
-- the renamed object_name is a variable, or any expression within the
-- renamed object_name contains references to variables or calls on
-- nonstatic functions; otherwise return True (RM 6.4.1(6.10/3))
----------------
-- Has_Prefix --
----------------
function Has_Prefix (N : Node_Id) return Boolean is
begin
if Is_Entity_Name (Obj)
and then Present (Renamed_Entity (Entity (Obj)))
then
Obj := Renamed_Entity (Entity (Obj));
if Nkind (Obj) = N_Explicit_Dereference
and then Is_Variable (Prefix (Obj))
then
Obj := Empty;
return
Nkind_In (N,
N_Attribute_Reference,
N_Expanded_Name,
N_Explicit_Dereference,
N_Indexed_Component,
N_Reference,
N_Selected_Component,
N_Slice);
end Has_Prefix;
elsif Nkind (Obj) = N_Indexed_Component then
-----------------
-- Is_Renaming --
-----------------
function Is_Renaming (N : Node_Id) return Boolean is
begin
return Is_Entity_Name (N)
and then Present (Renamed_Entity (Entity (N)));
end Is_Renaming;
-----------------------
-- Is_Valid_Renaming --
-----------------------
function Is_Valid_Renaming (N : Node_Id) return Boolean is
function Check_Renaming (N : Node_Id) return Boolean;
-- Recursive function used to traverse all the prefixes of N
function Check_Renaming (N : Node_Id) return Boolean is
begin
if Is_Renaming (N)
and then not Check_Renaming (Renamed_Entity (Entity (N)))
then
return False;
end if;
if Nkind (N) = N_Indexed_Component then
declare
Indx : Node_Id;
begin
Indx := First (Expressions (Obj));
Indx := First (Expressions (N));
while Present (Indx) loop
if not Is_OK_Static_Expression (Indx) then
Obj := Empty;
exit;
return False;
end if;
Next_Index (Indx);
end loop;
end;
end if;
end if;
end Check_Renaming;
if Has_Prefix (N) then
declare
P : constant Node_Id := Prefix (N);
begin
if Nkind (N) = N_Explicit_Dereference
and then Is_Variable (P)
then
return False;
elsif Is_Entity_Name (P)
and then Ekind (Entity (P)) = E_Function
then
return False;
elsif Nkind (P) = N_Function_Call then
return False;
end if;
-- Recursion to continue traversing the prefix of the
-- renaming expression
return Check_Renaming (P);
end;
end if;
return True;
end Check_Renaming;
-- Start of processing for Is_Valid_Renaming
begin
return Check_Renaming (N);
end Is_Valid_Renaming;
-- Start of processing for Denotes_Same_Object
begin
Check_Renaming (Obj1);
Check_Renaming (Obj2);
-- Both names statically denote the same stand-alone object or parameter
-- (RM 6.4.1(6.5/3))
if No (Obj1)
or else No (Obj2)
if Is_Entity_Name (Obj1)
and then Is_Entity_Name (Obj2)
and then Entity (Obj1) = Entity (Obj2)
then
return False;
return True;
end if;
-- If we have entity names, then must be same entity
-- For renamings, the prefix of any dereference within the renamed
-- object_name is not a variable, and any expression within the
-- renamed object_name contains no references to variables nor
-- calls on nonstatic functions (RM 6.4.1(6.10/3)).
if Is_Entity_Name (Obj1) then
if Is_Renaming (Obj1) then
if Is_Valid_Renaming (Obj1) then
Obj1 := Renamed_Entity (Entity (Obj1));
else
return False;
end if;
end if;
if Is_Renaming (Obj2) then
if Is_Valid_Renaming (Obj2) then
Obj2 := Renamed_Entity (Entity (Obj2));
else
return False;
end if;
end if;
-- No match if not same node kind (such cases are handled by
-- Denotes_Same_Prefix)
if Nkind (Obj1) /= Nkind (Obj2) then
return False;
-- After handling valid renamings, one of the two names statically
-- denoted a renaming declaration whose renamed object_name is known
-- to denote the same object as the other (RM 6.4.1(6.10/3))
elsif Is_Entity_Name (Obj1) then
if Is_Entity_Name (Obj2) then
return Entity (Obj1) = Entity (Obj2);
else
return False;
end if;
-- No match if not same node kind
elsif Nkind (Obj1) /= Nkind (Obj2) then
return False;
-- For selected components, must have same prefix and selector
-- Both names are selected_components, their prefixes are known to
-- denote the same object, and their selector_names denote the same
-- component (RM 6.4.1(6.6/3)
elsif Nkind (Obj1) = N_Selected_Component then
return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
and then
Entity (Selector_Name (Obj1)) = Entity (Selector_Name (Obj2));
-- For explicit dereferences, prefixes must be same
-- Both names are dereferences and the dereferenced names are known to
-- denote the same object (RM 6.4.1(6.7/3))
elsif Nkind (Obj1) = N_Explicit_Dereference then
return Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2));
-- For indexed components, prefixes and all subscripts must be the same
-- Both names are indexed_components, their prefixes are known to denote
-- the same object, and each of the pairs of corresponding index values
-- are either both static expressions with the same static value or both
-- names that are known to denote the same object (RM 6.4.1(6.8/3))
elsif Nkind (Obj1) = N_Indexed_Component then
if Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
if not Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2)) then
return False;
else
declare
Indx1 : Node_Id;
Indx2 : Node_Id;
@ -2924,11 +3025,11 @@ package body Sem_Util is
return True;
end;
else
return False;
end if;
-- For slices, prefixes must match and bounds must match
-- Both names are slices, their prefixes are known to denote the same
-- object, and the two slices have statically matching index constraints
-- (RM 6.4.1(6.9/3))
elsif Nkind (Obj1) = N_Slice
and then Denotes_Same_Object (Prefix (Obj1), Prefix (Obj2))
@ -2947,10 +3048,11 @@ package body Sem_Util is
and then Denotes_Same_Object (Hi1, Hi2);
end;
-- Literals will appear as indexes. Isn't this where we should check
-- Known_At_Compile_Time at least if we are generating warnings ???
-- In the recursion, literals appear as indexes.
elsif Nkind (Obj1) = N_Integer_Literal then
elsif Nkind (Obj1) = N_Integer_Literal
and then Nkind (Obj2) = N_Integer_Literal
then
return Intval (Obj1) = Intval (Obj2);
else
@ -3014,7 +3116,7 @@ package body Sem_Util is
end loop;
-- If both have the same depth and they do not denote the same
-- object, they are disjoint and not warning is needed.
-- object, they are disjoint and no warning is needed.
if Depth1 = Depth2 then
return False;

3
gcc/ada/sem_util.ads
View File

@ -360,6 +360,9 @@ package Sem_Util is
-- and constraint checks on entry families constrained by discriminants.
function Denotes_Same_Object (A1, A2 : Node_Id) return Boolean;
-- Detect suspicious overlapping between actuals in a call, when both are
-- writable (RM 2012 6.4.1(6.4/3))
function Denotes_Same_Prefix (A1, A2 : Node_Id) return Boolean;
-- Functions to detect suspicious overlapping between actuals in a call,
-- when one of them is writable. The predicates are those proposed in