diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 44 | ||||
| -rw-r--r-- | gcc/ada/einfo.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 22 | ||||
| -rw-r--r-- | gcc/ada/exp_ch11.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/s-tpobop.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 26 | ||||
| -rw-r--r-- | gcc/ada/sem_elab.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 188 | ||||
| -rw-r--r-- | gcc/ada/sem_util.ads | 3 |
12 files changed, 265 insertions, 76 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 56a36b10e24..a7440cf20c8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -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. diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index b4b5159e9e6..3eb514404f5 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -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"); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index f6407715ab3..55acb34dede 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -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); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 10a4a560984..0f8f187cd34 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -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; diff --git a/gcc/ada/exp_ch11.adb b/gcc/ada/exp_ch11.adb index 07b631de6eb..64a53e36cda 100644 --- a/gcc/ada/exp_ch11.adb +++ b/gcc/ada/exp_ch11.adb @@ -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)); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 29d8182ff83..2ee01133c8d 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -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 diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 5df4c727194..291a9f3bedf 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -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 diff --git a/gcc/ada/s-tpobop.adb b/gcc/ada/s-tpobop.adb index 0ed75a8c392..aaf18208e59 100644 --- a/gcc/ada/s-tpobop.adb +++ b/gcc/ada/s-tpobop.adb @@ -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); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 37e521cb099..548656f9574 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -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 diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 4c86ce353a4..1c897c8147f 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -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))); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 648362c658f..907efe4c1e6 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -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 + + 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; @@ -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; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index b4ce100cb98..7c8d80357fd 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -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 |