+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.
-- Wrapped_Entity Node27
-- Extra_Formals Node28
+ -- Initialization_Statements Node28
-- Underlying_Record_View Node28
-- Subprograms_For_Type Node29
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);
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);
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");
-- 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
-- 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)
-- 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)
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;
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);
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
(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;
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));
-- 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
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
-- --
-- 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- --
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);
-- 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);
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
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)));
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
+
+ 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))
- procedure Check_Renaming (Obj : in out Node_Id) is
+ ----------------
+ -- 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))
+ 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;
+
+ -----------------
+ -- 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
- Obj := Empty;
+ return False;
+ end if;
- elsif Nkind (Obj) = N_Indexed_Component then
+ 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_Entity_Name (Obj2) then
- return Entity (Obj1) = Entity (Obj2);
+ if Is_Renaming (Obj1) then
+ if Is_Valid_Renaming (Obj1) then
+ Obj1 := Renamed_Entity (Entity (Obj1));
else
return False;
end if;
+ end if;
- -- No match if not same node kind
+ 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)
- elsif Nkind (Obj1) /= Nkind (Obj2) then
+ if Nkind (Obj1) /= Nkind (Obj2) then
return False;
- -- For selected components, must have same prefix and selector
+ -- 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;
+
+ -- 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;
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))
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
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;
-- 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
projects / thirdparty / gcc.git / commitdiff
