diff options
| author | Arnaud Charlet <charlet@gcc.gnu.org> | 2017-01-12 15:40:14 +0100 |
|---|---|---|
| committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2017-01-12 15:40:14 +0100 |
| commit | 2168d7cc3ba6f3b2280bfefcc8a789ea4d8d90a5 (patch) | |
| tree | 9bd16a83c4a282ddbe95d43f0b278466d6e4d5b8 /gcc | |
| parent | 4704f28e7a59c82fab92109ac6f22e3b14a0344b (diff) | |
| download | gcc-2168d7cc3ba6f3b2280bfefcc8a789ea4d8d90a5.zip gcc-2168d7cc3ba6f3b2280bfefcc8a789ea4d8d90a5.tar.gz gcc-2168d7cc3ba6f3b2280bfefcc8a789ea4d8d90a5.tar.bz2 | |
[multiple changes]
2017-01-12 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch9.adb, sem_prag.adb, s-tassta.adb, sem_util.adb, s-tarest.adb,
sem_ch13.adb: Minor reformatting.
2017-01-12 Hristian Kirtchev <kirtchev@adacore.com>
* exp_aggr.adb (Build_Record_Aggr_Code): Guard against a missing
adjustment primitive when the ancestor type was not properly frozen.
(Gen_Assign): Guard against a missing initialization
primitive when the component type was not properly frozen.
(Initialize_Array_Component): Guard against a missing adjustment
primitive when the component type was not properly frozen.
(Initialize_Record_Component): Guard against a missing adjustment
primitive when the component type was not properly frozen.
(Process_Transient_Component_Completion): The transient object may
not be finalized when its associated type was not properly frozen.
* exp_ch3.adb (Build_Assignment): Guard against a missing
adjustment primitive when the component type was not properly frozen.
(Build_Initialization_Call): Guard against a missing
initialization primitive when the associated type was not properly
frozen.
(Expand_N_Object_Declaration): Guard against a missing
adjustment primitive when the base type was not properly frozen.
(Predefined_Primitive_Bodies): Create an empty Deep_Adjust
body when there is no adjustment primitive available. Create an
empty Deep_Finalize body when there is no finalization primitive
available.
* exp_ch4.adb (Apply_Accessibility_Check): Guard against a
missing finalization primitive when the designated type was
not properly frozen.
(Expand_N_Allocator): Guard against a missing initialization primitive
when the designated type was not properly frozen.
* exp_ch5.adb (Make_Tag_Ctrl_Assignment): Add the adjustment call
only when the corresponding adjustment primitive is available.
* exp_ch7.adb (Build_Adjust_Or_Finalize_Statements): Generate the
adjustment/finalization statements only when there is an available
primitive to carry out the action.
(Build_Initialize_Statements): Generate the initialization/finalization
statements only when there is an available primitive to carry out the
action.
(Make_Adjust_Call): Do not generate a call when the underlying
type is not present due to a possible missing full view.
(Make_Final_Call): Do not generate a call when the underlying
type is not present due to a possible missing full view.
(Make_Finalize_Address_Stmts): Generate an empty body when the
designated type lacks a finalization primitive.
(Make_Init_Call): Do not generate a call when the underlying type is
not present due to a possible missing full view.
(Process_Component_For_Adjust): Add the adjustment call only when the
corresponding adjustment primitive is available.
(Process_Component_For_Finalize): Add the finalization call only when
the corresponding finalization primitive is available.
(Process_Object_Declaration): Use a null statement to emulate a
missing call to the finalization primitive of the object type.
* exp_ch7.ads (Make_Adjust_Call): Update the comment on usage.
(Make_Final_Call): Update the comment on usage.
(Make_Init_Call): Update the comment on usage.
* exp_util.adb (Build_Transient_Object_Statements): Code reformatting.
2017-01-12 Arnaud Charlet <charlet@adacore.com>
* einfo.ads: Update documentation of Address_Taken.
* sem_attr.adb (Analyze_Access_Attribute, Resolve_Attribute
[Access_Attribute]): Only consider 'Access/'Unchecked_Access
for subprograms when setting Address_Taken flag.
2017-01-12 Patrick Bernardi <bernardi@adacore.com>
* sem_ch10.adb (Analyze_With_Clause): Removed code that turned
Configurable_Run_Time_Mode off when analysing with'ed predefined
libraries.
From-SVN: r244365
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/ChangeLog | 73 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 8 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 70 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 103 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 28 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 20 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 809 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.ads | 24 | ||||
| -rw-r--r-- | gcc/ada/exp_ch9.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/s-tarest.adb | 10 | ||||
| -rw-r--r-- | gcc/ada/s-tassta.adb | 4 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 21 | ||||
| -rw-r--r-- | gcc/ada/sem_ch10.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/sem_ch13.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 20 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 9 |
17 files changed, 767 insertions, 471 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 321b2e6..233582f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,76 @@ +2017-01-12 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_ch9.adb, sem_prag.adb, s-tassta.adb, sem_util.adb, s-tarest.adb, + sem_ch13.adb: Minor reformatting. + +2017-01-12 Hristian Kirtchev <kirtchev@adacore.com> + + * exp_aggr.adb (Build_Record_Aggr_Code): Guard against a missing + adjustment primitive when the ancestor type was not properly frozen. + (Gen_Assign): Guard against a missing initialization + primitive when the component type was not properly frozen. + (Initialize_Array_Component): Guard against a missing adjustment + primitive when the component type was not properly frozen. + (Initialize_Record_Component): Guard against a missing adjustment + primitive when the component type was not properly frozen. + (Process_Transient_Component_Completion): The transient object may + not be finalized when its associated type was not properly frozen. + * exp_ch3.adb (Build_Assignment): Guard against a missing + adjustment primitive when the component type was not properly frozen. + (Build_Initialization_Call): Guard against a missing + initialization primitive when the associated type was not properly + frozen. + (Expand_N_Object_Declaration): Guard against a missing + adjustment primitive when the base type was not properly frozen. + (Predefined_Primitive_Bodies): Create an empty Deep_Adjust + body when there is no adjustment primitive available. Create an + empty Deep_Finalize body when there is no finalization primitive + available. + * exp_ch4.adb (Apply_Accessibility_Check): Guard against a + missing finalization primitive when the designated type was + not properly frozen. + (Expand_N_Allocator): Guard against a missing initialization primitive + when the designated type was not properly frozen. + * exp_ch5.adb (Make_Tag_Ctrl_Assignment): Add the adjustment call + only when the corresponding adjustment primitive is available. + * exp_ch7.adb (Build_Adjust_Or_Finalize_Statements): Generate the + adjustment/finalization statements only when there is an available + primitive to carry out the action. + (Build_Initialize_Statements): Generate the initialization/finalization + statements only when there is an available primitive to carry out the + action. + (Make_Adjust_Call): Do not generate a call when the underlying + type is not present due to a possible missing full view. + (Make_Final_Call): Do not generate a call when the underlying + type is not present due to a possible missing full view. + (Make_Finalize_Address_Stmts): Generate an empty body when the + designated type lacks a finalization primitive. + (Make_Init_Call): Do not generate a call when the underlying type is + not present due to a possible missing full view. + (Process_Component_For_Adjust): Add the adjustment call only when the + corresponding adjustment primitive is available. + (Process_Component_For_Finalize): Add the finalization call only when + the corresponding finalization primitive is available. + (Process_Object_Declaration): Use a null statement to emulate a + missing call to the finalization primitive of the object type. + * exp_ch7.ads (Make_Adjust_Call): Update the comment on usage. + (Make_Final_Call): Update the comment on usage. + (Make_Init_Call): Update the comment on usage. + * exp_util.adb (Build_Transient_Object_Statements): Code reformatting. + +2017-01-12 Arnaud Charlet <charlet@adacore.com> + + * einfo.ads: Update documentation of Address_Taken. + * sem_attr.adb (Analyze_Access_Attribute, Resolve_Attribute + [Access_Attribute]): Only consider 'Access/'Unchecked_Access + for subprograms when setting Address_Taken flag. + +2017-01-12 Patrick Bernardi <bernardi@adacore.com> + + * sem_ch10.adb (Analyze_With_Clause): Removed code that turned + Configurable_Run_Time_Mode off when analysing with'ed predefined + libraries. + 2017-01-12 Gary Dismukes <dismukes@adacore.com> * sem_prag.adb: Minor reformatting. diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index b935431..d3820af 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -393,9 +393,11 @@ package Einfo is -- attribute is applied directly to the entity, i.e. the entity is the -- entity of the prefix of the attribute reference. Also set if the -- entity is the second argument of an Asm_Input or Asm_Output attribute, --- as the construct may entail taking its address. Used by the backend to --- make sure that the address can be meaningfully taken, and also in the --- case of subprograms to control output of certain warnings. +-- as the construct may entail taking its address. And also set if the +-- entity is a subprogram and the Access or Unchecked_Access attribute is +-- applied. Used by the backend to make sure that the address can be +-- meaningfully taken, and also in the case of subprograms to control +-- output of certain warnings. -- Aft_Value (synthesized) -- Applies to fixed and decimal types. Computes a universal integer that diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index e83b07a..f058c61 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -1128,6 +1128,7 @@ package body Exp_Aggr is and then Needs_Finalization (Comp_Typ); Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ); + Adj_Call : Node_Id; Blk_Stmts : List_Id; Init_Stmt : Node_Id; @@ -1222,10 +1223,17 @@ package body Exp_Aggr is and then Is_Controlled (Component_Type (Comp_Typ)) and then Nkind (Expr) = N_Aggregate) then - Append_To (Blk_Stmts, + Adj_Call := Make_Adjust_Call (Obj_Ref => New_Copy_Tree (Arr_Comp), - Typ => Comp_Typ)); + Typ => Comp_Typ); + + -- Guard against a missing [Deep_]Adjust when the component + -- type was not frozen properly. + + if Present (Adj_Call) then + Append_To (Blk_Stmts, Adj_Call); + end if; end if; -- Complete the protection of the initialization statements @@ -1390,6 +1398,7 @@ package body Exp_Aggr is Comp_Typ : Entity_Id := Empty; Expr_Q : Node_Id; Indexed_Comp : Node_Id; + Init_Call : Node_Id; New_Indexes : List_Id; -- Start of processing for Gen_Assign @@ -1613,10 +1622,17 @@ package body Exp_Aggr is end if; if Needs_Finalization (Ctype) then - Append_To (Stmts, + Init_Call := Make_Init_Call (Obj_Ref => New_Copy_Tree (Indexed_Comp), - Typ => Ctype)); + Typ => Ctype); + + -- Guard against a missing [Deep_]Initialize when the component + -- type was not properly frozen. + + if Present (Init_Call) then + Append_To (Stmts, Init_Call); + end if; end if; end if; @@ -2847,6 +2863,7 @@ package body Exp_Aggr is Finalization_OK : constant Boolean := Needs_Finalization (Comp_Typ); Full_Typ : constant Entity_Id := Underlying_Type (Comp_Typ); + Adj_Call : Node_Id; Blk_Stmts : List_Id; Init_Stmt : Node_Id; @@ -2912,10 +2929,17 @@ package body Exp_Aggr is -- [Deep_]Adjust (Rec_Comp); if Finalization_OK and then not Is_Limited_Type (Comp_Typ) then - Append_To (Blk_Stmts, + Adj_Call := Make_Adjust_Call (Obj_Ref => New_Copy_Tree (Rec_Comp), - Typ => Comp_Typ)); + Typ => Comp_Typ); + + -- Guard against a missing [Deep_]Adjust when the component type + -- was not properly frozen. + + if Present (Adj_Call) then + Append_To (Blk_Stmts, Adj_Call); + end if; end if; -- Complete the protection of the initialization statements @@ -3062,6 +3086,7 @@ package body Exp_Aggr is if Nkind (N) = N_Extension_Aggregate then declare Ancestor : constant Node_Id := Ancestor_Part (N); + Adj_Call : Node_Id; Assign : List_Id; begin @@ -3274,10 +3299,17 @@ package body Exp_Aggr is if Needs_Finalization (Etype (Ancestor)) and then not Is_Limited_Type (Etype (Ancestor)) then - Append_To (Assign, + Adj_Call := Make_Adjust_Call (Obj_Ref => New_Copy_Tree (Ref), - Typ => Etype (Ancestor))); + Typ => Etype (Ancestor)); + + -- Guard against a missing [Deep_]Adjust when the ancestor + -- type was not properly frozen. + + if Present (Adj_Call) then + Append_To (Assign, Adj_Call); + end if; end if; Append_To (L, @@ -7832,7 +7864,6 @@ package body Exp_Aggr is not Restriction_Active (No_Exception_Propagation); begin - pragma Assert (Present (Fin_Call)); pragma Assert (Present (Hook_Clear)); -- Generate the following code if exception propagation is allowed: @@ -7872,6 +7903,7 @@ package body Exp_Aggr is Abort_And_Exception : declare Blk_Decls : constant List_Id := New_List; Blk_Stmts : constant List_Id := New_List; + Fin_Stmts : constant List_Id := New_List; Fin_Data : Finalization_Exception_Data; @@ -7892,13 +7924,17 @@ package body Exp_Aggr is -- Wrap the hook clear and the finalization call in order to trap -- a potential exception. + Append_To (Fin_Stmts, Hook_Clear); + + if Present (Fin_Call) then + Append_To (Fin_Stmts, Fin_Call); + end if; + Append_To (Blk_Stmts, Make_Block_Statement (Loc, Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Hook_Clear, - Fin_Call), + Statements => Fin_Stmts, Exception_Handlers => New_List ( Build_Exception_Handler (Fin_Data))))); @@ -7943,7 +7979,10 @@ package body Exp_Aggr is begin Append_To (Blk_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer)); Append_To (Blk_Stmts, Hook_Clear); - Append_To (Blk_Stmts, Fin_Call); + + if Present (Fin_Call) then + Append_To (Blk_Stmts, Fin_Call); + end if; Append_To (Stmts, Build_Abort_Undefer_Block (Loc, @@ -7958,7 +7997,10 @@ package body Exp_Aggr is else Append_To (Stmts, Hook_Clear); - Append_To (Stmts, Fin_Call); + + if Present (Fin_Call) then + Append_To (Stmts, Fin_Call); + end if; end if; end Process_Transient_Component_Completion; diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index ae639dc..068674d 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1295,6 +1295,7 @@ package body Exp_Ch3 is First_Arg : Node_Id; Full_Init_Type : Entity_Id; Full_Type : Entity_Id; + Init_Call : Node_Id; Init_Type : Entity_Id; Proc : Entity_Id; @@ -1515,7 +1516,7 @@ package body Exp_Ch3 is then Append_To (Args, Make_Selected_Component (Loc, - Prefix => New_Copy_Tree (Prefix (Id_Ref)), + Prefix => New_Copy_Tree (Prefix (Id_Ref)), Selector_Name => Arg)); else Append_To (Args, Arg); @@ -1542,17 +1543,24 @@ package body Exp_Ch3 is Append_To (Res, Make_Procedure_Call_Statement (Loc, - Name => New_Occurrence_Of (Proc, Loc), + Name => New_Occurrence_Of (Proc, Loc), Parameter_Associations => Args)); if Needs_Finalization (Typ) and then Nkind (Id_Ref) = N_Selected_Component then if Chars (Selector_Name (Id_Ref)) /= Name_uParent then - Append_To (Res, + Init_Call := Make_Init_Call (Obj_Ref => New_Copy_Tree (First_Arg), - Typ => Typ)); + Typ => Typ); + + -- Guard against a missing [Deep_]Initialize when the type was not + -- properly frozen. + + if Present (Init_Call) then + Append_To (Res, Init_Call); + end if; end if; end if; @@ -1651,10 +1659,12 @@ package body Exp_Ch3 is function Build_Assignment (Id : Entity_Id; N : Node_Id) return List_Id is N_Loc : constant Source_Ptr := Sloc (N); Typ : constant Entity_Id := Underlying_Type (Etype (Id)); - Exp : Node_Id := N; - Kind : Node_Kind := Nkind (N); - Lhs : Node_Id; - Res : List_Id; + + Adj_Call : Node_Id; + Exp : Node_Id := N; + Kind : Node_Kind := Nkind (N); + Lhs : Node_Id; + Res : List_Id; begin Lhs := @@ -1734,10 +1744,17 @@ package body Exp_Ch3 is and then not (Nkind_In (Kind, N_Aggregate, N_Extension_Aggregate)) and then not Is_Limited_View (Typ) then - Append_To (Res, + Adj_Call := Make_Adjust_Call (Obj_Ref => New_Copy_Tree (Lhs), - Typ => Etype (Id))); + Typ => Etype (Id)); + + -- Guard against a missing [Deep_]Adjust when the component type + -- was not properly frozen. + + if Present (Adj_Call) then + Append_To (Res, Adj_Call); + end if; end if; -- If a component type has a predicate, add check to the component @@ -5830,7 +5847,9 @@ package body Exp_Ch3 is -- Local variables - Next_N : constant Node_Id := Next (N); + Next_N : constant Node_Id := Next (N); + + Adj_Call : Node_Id; Id_Ref : Node_Id; Tag_Assign : Node_Id; @@ -6332,10 +6351,17 @@ package body Exp_Ch3 is and then not Is_Limited_View (Typ) and then not Rewrite_As_Renaming then - Insert_Action_After (Init_After, + Adj_Call := Make_Adjust_Call ( Obj_Ref => New_Occurrence_Of (Def_Id, Loc), - Typ => Base_Typ)); + Typ => Base_Typ); + + -- Guard against a missing [Deep_]Adjust when the base type + -- was not properly frozen. + + if Present (Adj_Call) then + Insert_Action_After (Init_After, Adj_Call); + end if; end if; -- For tagged types, when an init value is given, the tag has to @@ -9530,7 +9556,9 @@ package body Exp_Ch3 is is Loc : constant Source_Ptr := Sloc (Tag_Typ); Res : constant List_Id := New_List; + Adj_Call : Node_Id; Decl : Node_Id; + Fin_Call : Node_Id; Prim : Elmt_Id; Eq_Needed : Boolean; Eq_Name : Name_Id; @@ -9756,42 +9784,45 @@ package body Exp_Ch3 is elsif not Has_Controlled_Component (Tag_Typ) then if not Is_Limited_Type (Tag_Typ) then - Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True); + Adj_Call := Empty; + Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Adjust, True); if Is_Controlled (Tag_Typ) then - Set_Handled_Statement_Sequence (Decl, - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Adjust_Call ( - Obj_Ref => Make_Identifier (Loc, Name_V), - Typ => Tag_Typ)))); + Adj_Call := + Make_Adjust_Call ( + Obj_Ref => Make_Identifier (Loc, Name_V), + Typ => Tag_Typ); + end if; - else - Set_Handled_Statement_Sequence (Decl, - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Null_Statement (Loc)))); + if No (Adj_Call) then + Adj_Call := Make_Null_Statement (Loc); end if; + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Adj_Call))); + Append_To (Res, Decl); end if; - Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True); + Fin_Call := Empty; + Decl := Predef_Deep_Spec (Loc, Tag_Typ, TSS_Deep_Finalize, True); if Is_Controlled (Tag_Typ) then - Set_Handled_Statement_Sequence (Decl, - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Final_Call - (Obj_Ref => Make_Identifier (Loc, Name_V), - Typ => Tag_Typ)))); + Fin_Call := + Make_Final_Call + (Obj_Ref => Make_Identifier (Loc, Name_V), + Typ => Tag_Typ); + end if; - else - Set_Handled_Statement_Sequence (Decl, - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Make_Null_Statement (Loc)))); + if No (Fin_Call) then + Fin_Call := Make_Null_Statement (Loc); end if; + Set_Handled_Statement_Sequence (Decl, + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Fin_Call))); + Append_To (Res, Decl); end if; diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 905467b..8241925 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -632,6 +632,13 @@ package body Exp_Ch4 is Make_Explicit_Dereference (Loc, New_Copy (Obj_Ref)), Typ => DesigT); + -- Guard against a missing [Deep_]Finalize when the designated + -- type was not properly frozen. + + if No (Fin_Call) then + Fin_Call := Make_Null_Statement (Loc); + end if; + -- When the target or profile supports deallocation, wrap the -- finalization call in a block to ensure proper deallocation -- even if finalization fails. Generate: @@ -722,6 +729,7 @@ package body Exp_Ch4 is Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp); Indic : constant Node_Id := Subtype_Mark (Expression (N)); T : constant Entity_Id := Entity (Indic); + Adj_Call : Node_Id; Node : Node_Id; Tag_Assign : Node_Id; Temp : Entity_Id; @@ -1060,13 +1068,17 @@ package body Exp_Ch4 is -- the designated type can be an ancestor of the subtype mark of -- the allocator. - Insert_Action (N, + Adj_Call := Make_Adjust_Call (Obj_Ref => Unchecked_Convert_To (T, Make_Explicit_Dereference (Loc, Prefix => New_Occurrence_Of (Temp, Loc))), - Typ => T)); + Typ => T); + + if Present (Adj_Call) then + Insert_Action (N, Adj_Call); + end if; end if; -- Note: the accessibility check must be inserted after the call to @@ -4315,6 +4327,7 @@ package body Exp_Ch4 is Discr : Elmt_Id; Init : Entity_Id; Init_Arg1 : Node_Id; + Init_Call : Node_Id; Temp_Decl : Node_Id; Temp_Type : Entity_Id; @@ -4635,10 +4648,17 @@ package body Exp_Ch4 is -- Generate: -- [Deep_]Initialize (Init_Arg1); - Insert_Action (N, + Init_Call := Make_Init_Call (Obj_Ref => New_Copy_Tree (Init_Arg1), - Typ => T)); + Typ => T); + + -- Guard against a missing [Deep_]Initialize when the + -- designated type was not properly frozen. + + if Present (Init_Call) then + Insert_Action (N, Init_Call); + end if; end if; Rewrite (N, New_Occurrence_Of (Temp, Loc)); diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index ed3703a..e6f076e 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -4676,7 +4676,9 @@ package body Exp_Ch5 is and then not Comp_Asn and then not No_Ctrl_Actions (N) and then Tagged_Type_Expansion; - Tag_Id : Entity_Id; + Adj_Call : Node_Id; + Fin_Call : Node_Id; + Tag_Id : Entity_Id; begin -- Finalize the target of the assignment when controlled @@ -4709,10 +4711,14 @@ package body Exp_Ch5 is null; else - Append_To (Res, + Fin_Call := Make_Final_Call (Obj_Ref => Duplicate_Subexpr_No_Checks (L), - Typ => Etype (L))); + Typ => Etype (L)); + + if Present (Fin_Call) then + Append_To (Res, Fin_Call); + end if; end if; -- Save the Tag in a local variable Tag_Id @@ -4765,10 +4771,14 @@ package body Exp_Ch5 is -- init proc since it is an initialization more than an assignment). if Ctrl_Act then - Append_To (Res, + Adj_Call := Make_Adjust_Call (Obj_Ref => Duplicate_Subexpr_Move_Checks (L), - Typ => Etype (L))); + Typ => Etype (L)); + + if Present (Adj_Call) then + Append_To (Res, Adj_Call); + end if; end if; return Res; diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 4282617..b4caa36 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -3062,6 +3062,13 @@ package body Exp_Ch7 is Obj_Ref => Obj_Ref, Typ => Obj_Typ); + -- Guard against a missing [Deep_]Finalize when the object type + -- was not properly frozen. + + if No (Fin_Call) then + Fin_Call := Make_Null_Statement (Loc); + end if; + -- For CodePeer, the exception handlers normally generated here -- generate complex flowgraphs which result in capacity problems. -- Omitting these handlers for CodePeer is justified as follows: @@ -6905,10 +6912,12 @@ package body Exp_Ch7 is is Loc : constant Source_Ptr := Sloc (Obj_Ref); Adj_Id : Entity_Id := Empty; - Ref : Node_Id := Obj_Ref; + Ref : Node_Id; Utyp : Entity_Id; begin + Ref := Obj_Ref; + -- Recover the proper type which contains Deep_Adjust if Is_Class_Wide_Type (Typ) then @@ -6922,7 +6931,7 @@ package body Exp_Ch7 is -- Deal with untagged derivation of private views - if Is_Untagged_Derivation (Typ) then + if Present (Utyp) and then Is_Untagged_Derivation (Typ) then Utyp := Underlying_Type (Root_Type (Base_Type (Typ))); Ref := Unchecked_Convert_To (Utyp, Ref); Set_Assignment_OK (Ref); @@ -6931,14 +6940,21 @@ package body Exp_Ch7 is -- When dealing with the completion of a private type, use the base -- type instead. - if Utyp /= Base_Type (Utyp) then + if Present (Utyp) and then Utyp /= Base_Type (Utyp) then pragma Assert (Is_Private_Type (Typ)); Utyp := Base_Type (Utyp); Ref := Unchecked_Convert_To (Utyp, Ref); end if; - if Skip_Self then + -- The underlying type may not be present due to a missing full view. In + -- this case freezing did not take place and there is no [Deep_]Adjust + -- primitive to call. + + if No (Utyp) then + return Empty; + + elsif Skip_Self then if Has_Controlled_Component (Utyp) then if Is_Tagged_Type (Utyp) then Adj_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Adjust); @@ -6998,7 +7014,7 @@ package body Exp_Ch7 is return Make_Call (Loc, Proc_Id => Adj_Id, - Param => New_Copy_Tree (Ref), + Param => Ref, Skip_Self => Skip_Self); else return Empty; @@ -7171,22 +7187,12 @@ package body Exp_Ch7 is function Build_Adjust_Or_Finalize_Statements (Typ : Entity_Id) return List_Id is - Comp_Typ : constant Entity_Id := Component_Type (Typ); - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); - Index_List : constant List_Id := New_List; - Loc : constant Source_Ptr := Sloc (Typ); - Num_Dims : constant Int := Number_Dimensions (Typ); - - Finalizer_Decls : List_Id := No_List; - Finalizer_Data : Finalization_Exception_Data; - Call : Node_Id; - Comp_Ref : Node_Id; - Core_Loop : Node_Id; - Dim : Int; - J : Entity_Id; - Loop_Id : Entity_Id; - Stmts : List_Id; + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + Index_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Num_Dims : constant Int := Number_Dimensions (Typ); procedure Build_Indexes; -- Generate the indexes used in the dimension loops @@ -7206,13 +7212,26 @@ package body Exp_Ch7 is end loop; end Build_Indexes; + -- Local variables + + Final_Decls : List_Id := No_List; + Final_Data : Finalization_Exception_Data; + Block : Node_Id; + Call : Node_Id; + Comp_Ref : Node_Id; + Core_Loop : Node_Id; + Dim : Int; + J : Entity_Id; + Loop_Id : Entity_Id; + Stmts : List_Id; + -- Start of processing for Build_Adjust_Or_Finalize_Statements begin - Finalizer_Decls := New_List; + Final_Decls := New_List; Build_Indexes; - Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); + Build_Object_Declarations (Final_Data, Final_Decls, Loc); Comp_Ref := Make_Indexed_Component (Loc, @@ -7233,99 +7252,111 @@ package body Exp_Ch7 is Call := Make_Final_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); end if; - -- Generate the block which houses the adjust or finalize call: - - -- begin - -- <adjust or finalize call> + if Present (Call) then - -- exception - -- when others => - -- if not Raised then - -- Raised := True; - -- Save_Occurrence (E, Get_Current_Excep.all.all); - -- end if; - -- end; + -- Generate the block which houses the adjust or finalize call: - if Exceptions_OK then - Core_Loop := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Call), - Exception_Handlers => New_List ( - Build_Exception_Handler (Finalizer_Data)))); - else - Core_Loop := Call; - end if; - - -- Generate the dimension loops starting from the innermost one + -- begin + -- <adjust or finalize call> - -- for Jnn in [reverse] V'Range (Dim) loop - -- <core loop> - -- end loop; + -- exception + -- when others => + -- if not Raised then + -- Raised := True; + -- Save_Occurrence (E, Get_Current_Excep.all.all); + -- end if; + -- end; - J := Last (Index_List); - Dim := Num_Dims; - while Present (J) and then Dim > 0 loop - Loop_Id := J; - Prev (J); - Remove (Loop_Id); + if Exceptions_OK then + Core_Loop := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Call), + Exception_Handlers => New_List ( + Build_Exception_Handler (Final_Data)))); + else + Core_Loop := Call; + end if; - Core_Loop := - Make_Loop_Statement (Loc, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Loop_Parameter_Specification => - Make_Loop_Parameter_Specification (Loc, - Defining_Identifier => Loop_Id, - Discrete_Subtype_Definition => - Make_Attribute_Reference (Loc, - Prefix => Make_Identifier (Loc, Name_V), - Attribute_Name => Name_Range, - Expressions => New_List ( - Make_Integer_Literal (Loc, Dim))), + -- Generate the dimension loops starting from the innermost one + + -- for Jnn in [reverse] V'Range (Dim) loop + -- <core loop> + -- end loop; + + J := Last (Index_List); + Dim := Num_Dims; + while Present (J) and then Dim > 0 loop + Loop_Id := J; + Prev (J); + Remove (Loop_Id); + + Core_Loop := + Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Loop_Id, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, Dim))), + + Reverse_Present => + Prim = Finalize_Case)), + + Statements => New_List (Core_Loop), + End_Label => Empty); + + Dim := Dim - 1; + end loop; - Reverse_Present => Prim = Finalize_Case)), + -- Generate the block which contains the core loop, declarations + -- of the abort flag, the exception occurrence, the raised flag + -- and the conditional raise: - Statements => New_List (Core_Loop), - End_Label => Empty); + -- declare + -- Abort : constant Boolean := Triggered_By_Abort; + -- <or> + -- Abort : constant Boolean := False; -- no abort - Dim := Dim - 1; - end loop; + -- E : Exception_Occurrence; + -- Raised : Boolean := False; - -- Generate the block which contains the core loop, the declarations - -- of the abort flag, the exception occurrence, the raised flag and - -- the conditional raise: + -- begin + -- <core loop> - -- declare - -- Abort : constant Boolean := Triggered_By_Abort; - -- <or> - -- Abort : constant Boolean := False; -- no abort + -- if Raised and then not Abort then + -- Raise_From_Controlled_Operation (E); + -- end if; + -- end; - -- E : Exception_Occurrence; - -- Raised : Boolean := False; + Stmts := New_List (Core_Loop); - -- begin - -- <core loop> + if Exceptions_OK then + Append_To (Stmts, Build_Raise_Statement (Final_Data)); + end if; - -- if Raised and then not Abort then - -- Raise_From_Controlled_Operation (E); - -- end if; - -- end; + Block := + Make_Block_Statement (Loc, + Declarations => Final_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); - Stmts := New_List (Core_Loop); + -- Otherwise previous errors or a missing full view may prevent the + -- proper freezing of the component type. If this is the case, there + -- is no [Deep_]Adjust or [Deep_]Finalize primitive to call. - if Exceptions_OK then - Append_To (Stmts, Build_Raise_Statement (Finalizer_Data)); + else + Block := Make_Null_Statement (Loc); end if; - return - New_List ( - Make_Block_Statement (Loc, - Declarations => - Finalizer_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, Stmts))); + return New_List (Block); end Build_Adjust_Or_Finalize_Statements; --------------------------------- @@ -7333,32 +7364,21 @@ package body Exp_Ch7 is --------------------------------- function Build_Initialize_Statements (Typ : Entity_Id) return List_Id is - Comp_Typ : constant Entity_Id := Component_Type (Typ); - Exceptions_OK : constant Boolean := - not Restriction_Active (No_Exception_Propagation); - Final_List : constant List_Id := New_List; - Index_List : constant List_Id := New_List; - Loc : constant Source_Ptr := Sloc (Typ); - Num_Dims : constant Int := Number_Dimensions (Typ); - - Counter_Id : Entity_Id; - Dim : Int; - F : Node_Id; - Fin_Stmt : Node_Id; - Final_Block : Node_Id; - Final_Loop : Node_Id; - Finalizer_Data : Finalization_Exception_Data; - Finalizer_Decls : List_Id := No_List; - Init_Loop : Node_Id; - J : Node_Id; - Loop_Id : Node_Id; - Stmts : List_Id; + Comp_Typ : constant Entity_Id := Component_Type (Typ); + Exceptions_OK : constant Boolean := + not Restriction_Active (No_Exception_Propagation); + Final_List : constant List_Id := New_List; + Index_List : constant List_Id := New_List; + Loc : constant Source_Ptr := Sloc (Typ); + Num_Dims : constant Int := Number_Dimensions (Typ); - function Build_Counter_Assignment return Node_Id; + function Build_Assignment (Counter_Id : Entity_Id) return Node_Id; -- Generate the following assignment: -- Counter := V'Length (1) * -- ... -- V'Length (N) - Counter; + -- + -- Counter_Id denotes the entity of the counter. function Build_Finalization_Call return Node_Id; -- Generate a deep finalization call for an array element @@ -7370,11 +7390,11 @@ package body Exp_Ch7 is function Build_Initialization_Call return Node_Id; -- Generate a deep initialization call for an array element - ------------------------------ - -- Build_Counter_Assignment -- - ------------------------------ + ---------------------- + -- Build_Assignment -- + ---------------------- - function Build_Counter_Assignment return Node_Id is + function Build_Assignment (Counter_Id : Entity_Id) return Node_Id is Dim : Int; Expr : Node_Id; @@ -7417,7 +7437,7 @@ package body Exp_Ch7 is Make_Op_Subtract (Loc, Left_Opnd => Expr, Right_Opnd => New_Occurrence_Of (Counter_Id, Loc))); - end Build_Counter_Assignment; + end Build_Assignment; ----------------------------- -- Build_Finalization_Call -- @@ -7476,14 +7496,31 @@ package body Exp_Ch7 is return Make_Init_Call (Obj_Ref => Comp_Ref, Typ => Comp_Typ); end Build_Initialization_Call; + -- Local variables + + Counter_Id : Entity_Id; + Dim : Int; + F : Node_Id; + Fin_Stmt : Node_Id; + Final_Block : Node_Id; + Final_Data : Finalization_Exception_Data; + Final_Decls : List_Id := No_List; + Final_Loop : Node_Id; + Init_Block : Node_Id; + Init_Call : Node_Id; + Init_Loop : Node_Id; + J : Node_Id; + Loop_Id : Node_Id; + Stmts : List_Id; + -- Start of processing for Build_Initialize_Statements begin - Counter_Id := Make_Temporary (Loc, 'C'); - Finalizer_Decls := New_List; + Counter_Id := Make_Temporary (Loc, 'C'); + Final_Decls := New_List; Build_Indexes; - Build_Object_Declarations (Finalizer_Data, Finalizer_Decls, Loc); + Build_Object_Declarations (Final_Data, Final_Decls, Loc); -- Generate the block which houses the finalization call, the index -- guard and the handler which triggers Program_Error later on. @@ -7502,115 +7539,124 @@ package body Exp_Ch7 is -- end; -- end if; - if Exceptions_OK then - Fin_Stmt := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Build_Finalization_Call), - Exception_Handlers => New_List ( - Build_Exception_Handler (Finalizer_Data)))); - else - Fin_Stmt := Build_Finalization_Call; - end if; - - -- This is the core of the loop, the dimension iterators are added - -- one by one in reverse. - - Final_Loop := - Make_If_Statement (Loc, - Condition => - Make_Op_Gt (Loc, - Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 0)), - - Then_Statements => New_List ( - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Counter_Id, Loc), - Expression => - Make_Op_Subtract (Loc, - Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 1)))), - - Else_Statements => New_List (Fin_Stmt)); - - -- Generate all finalization loops starting from the innermost - -- dimension. + Fin_Stmt := Build_Finalization_Call; - -- for Fnn in reverse V'Range (Dim) loop - -- <final loop> - -- end loop; + if Present (Fin_Stmt) then + if Exceptions_OK then + Fin_Stmt := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Fin_Stmt), + Exception_Handlers => New_List ( + Build_Exception_Handler (Final_Data)))); + end if; - F := Last (Final_List); - Dim := Num_Dims; - while Present (F) and then Dim > 0 loop - Loop_Id := F; - Prev (F); - Remove (Loop_Id); + -- This is the core of the loop, the dimension iterators are added + -- one by one in reverse. Final_Loop := - Make_Loop_Statement (Loc, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Loop_Parameter_Specification => - Make_Loop_Parameter_Specification (Loc, - Defining_Identifier => Loop_Id, - Discrete_Subtype_Definition => - Make_Attribute_Reference (Loc, - Prefix => Make_Identifier (Loc, Name_V), - Attribute_Name => Name_Range, - Expressions => New_List ( - Make_Integer_Literal (Loc, Dim))), + Make_If_Statement (Loc, + Condition => + Make_Op_Gt (Loc, + Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 0)), + + Then_Statements => New_List ( + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Counter_Id, Loc), + Expression => + Make_Op_Subtract (Loc, + Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)))), + + Else_Statements => New_List (Fin_Stmt)); + + -- Generate all finalization loops starting from the innermost + -- dimension. + + -- for Fnn in reverse V'Range (Dim) loop + -- <final loop> + -- end loop; + + F := Last (Final_List); + Dim := Num_Dims; + while Present (F) and then Dim > 0 loop + Loop_Id := F; + Prev (F); + Remove (Loop_Id); + + Final_Loop := + Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Loop_Id, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, Dim))), + + Reverse_Present => True)), + + Statements => New_List (Final_Loop), + End_Label => Empty); + + Dim := Dim - 1; + end loop; - Reverse_Present => True)), + -- Generate the block which contains the finalization loops, the + -- declarations of the abort flag, the exception occurrence, the + -- raised flag and the conditional raise. - Statements => New_List (Final_Loop), - End_Label => Empty); + -- declare + -- Abort : constant Boolean := Triggered_By_Abort; + -- <or> + -- Abort : constant Boolean := False; -- no abort - Dim := Dim - 1; - end loop; + -- E : Exception_Occurrence; + -- Raised : Boolean := False; - -- Generate the block which contains the finalization loops, the - -- declarations of the abort flag, the exception occurrence, the - -- raised flag and the conditional raise. + -- begin + -- Counter := + -- V'Length (1) * + -- ... + -- V'Length (N) - Counter; - -- declare - -- Abort : constant Boolean := Triggered_By_Abort; - -- <or> - -- Abort : constant Boolean := False; -- no abort + -- <final loop> - -- E : Exception_Occurrence; - -- Raised : Boolean := False; + -- if Raised and then not Abort then + -- Raise_From_Controlled_Operation (E); + -- end if; - -- begin - -- Counter := - -- V'Length (1) * - -- ... - -- V'Length (N) - Counter; + -- raise; + -- end; - -- <final loop> + Stmts := New_List (Build_Assignment (Counter_Id), Final_Loop); - -- if Raised and then not Abort then - -- Raise_From_Controlled_Operation (E); - -- end if; + if Exceptions_OK then + Append_To (Stmts, Build_Raise_Statement (Final_Data)); + Append_To (Stmts, Make_Raise_Statement (Loc)); + end if; - -- raise; - -- end; + Final_Block := + Make_Block_Statement (Loc, + Declarations => Final_Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => Stmts)); - Stmts := New_List (Build_Counter_Assignment, Final_Loop); + -- Otherwise previous errors or a missing full view may prevent the + -- proper freezing of the component type. If this is the case, there + -- is no [Deep_]Finalize primitive to call. - if Exceptions_OK then - Append_To (Stmts, Build_Raise_Statement (Finalizer_Data)); - Append_To (Stmts, Make_Raise_Statement (Loc)); + else + Final_Block := Make_Null_Statement (Loc); end if; - Final_Block := - Make_Block_Statement (Loc, - Declarations => - Finalizer_Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)); - -- Generate the block which contains the initialization call and -- the partial finalization code. @@ -7624,70 +7670,73 @@ package body Exp_Ch7 is -- <finalization code> -- end; - Init_Loop := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Build_Initialization_Call), - Exception_Handlers => New_List ( - Make_Exception_Handler (Loc, - Exception_Choices => New_List (Make_Others_Choice (Loc)), - Statements => New_List (Final_Block))))); - - Append_To (Statements (Handled_Statement_Sequence (Init_Loop)), - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Counter_Id, Loc), - Expression => - Make_Op_Add (Loc, - Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 1)))); - - -- Generate all initialization loops starting from the innermost - -- dimension. - - -- for Jnn in V'Range (Dim) loop - -- <init loop> - -- end loop; - - J := Last (Index_List); - Dim := Num_Dims; - while Present (J) and then Dim > 0 loop - Loop_Id := J; - Prev (J); - Remove (Loop_Id); + Init_Call := Build_Initialization_Call; + if Present (Init_Call) then Init_Loop := - Make_Loop_Statement (Loc, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Loop_Parameter_Specification => - Make_Loop_Parameter_Specification (Loc, - Defining_Identifier => Loop_Id, - Discrete_Subtype_Definition => - Make_Attribute_Reference (Loc, - Prefix => Make_Identifier (Loc, Name_V), - Attribute_Name => Name_Range, - Expressions => New_List ( - Make_Integer_Literal (Loc, Dim))))), - - Statements => New_List (Init_Loop), - End_Label => Empty); + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Init_Call), + Exception_Handlers => New_List ( + Make_Exception_Handler (Loc, + Exception_Choices => New_List ( + Make_Others_Choice (Loc)), + Statements => New_List (Final_Block))))); - Dim := Dim - 1; - end loop; + Append_To (Statements (Handled_Statement_Sequence (Init_Loop)), + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Counter_Id, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Counter_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1)))); + + -- Generate all initialization loops starting from the innermost + -- dimension. + + -- for Jnn in V'Range (Dim) loop + -- <init loop> + -- end loop; + + J := Last (Index_List); + Dim := Num_Dims; + while Present (J) and then Dim > 0 loop + Loop_Id := J; + Prev (J); + Remove (Loop_Id); + + Init_Loop := + Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Loop_Parameter_Specification => + Make_Loop_Parameter_Specification (Loc, + Defining_Identifier => Loop_Id, + Discrete_Subtype_Definition => + Make_Attribute_Reference (Loc, + Prefix => Make_Identifier (Loc, Name_V), + Attribute_Name => Name_Range, + Expressions => New_List ( + Make_Integer_Literal (Loc, Dim))))), + + Statements => New_List (Init_Loop), + End_Label => Empty); + + Dim := Dim - 1; + end loop; - -- Generate the block which contains the counter variable and the - -- initialization loops. + -- Generate the block which contains the counter variable and the + -- initialization loops. - -- declare - -- Counter : Integer := 0; - -- begin - -- <init loop> - -- end; + -- declare + -- Counter : Integer := 0; + -- begin + -- <init loop> + -- end; - return - New_List ( - Make_Block_Statement (Loc, + Init_Block := + Make_Block_Statement (Loc, Declarations => New_List ( Make_Object_Declaration (Loc, Defining_Identifier => Counter_Id, @@ -7697,7 +7746,17 @@ package body Exp_Ch7 is Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Init_Loop)))); + Statements => New_List (Init_Loop))); + + -- Otherwise previous errors or a missing full view may prevent the + -- proper freezing of the component type. If this is the case, there + -- is no [Deep_]Initialize primitive to call. + + else + Init_Block := Make_Null_Statement (Loc); + end if; + + return New_List (Init_Block); end Build_Initialize_Statements; ----------------------- @@ -7983,7 +8042,8 @@ package body Exp_Ch7 is Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); Loc : constant Source_Ptr := Sloc (Typ); - Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); + Typ_Def : constant Node_Id := + Type_Definition (Parent (Typ)); Bod_Stmts : List_Id; Finalizer_Data : Finalization_Exception_Data; @@ -8002,12 +8062,7 @@ package body Exp_Ch7 is function Process_Component_List_For_Adjust (Comps : Node_Id) return List_Id is - Stmts : constant List_Id := New_List; - Decl : Node_Id; - Decl_Id : Entity_Id; - Decl_Typ : Entity_Id; - Has_POC : Boolean; - Num_Comps : Nat; + Stmts : constant List_Id := New_List; procedure Process_Component_For_Adjust (Decl : Node_Id); -- Process the declaration of a single controlled component @@ -8017,9 +8072,10 @@ package body Exp_Ch7 is ---------------------------------- procedure Process_Component_For_Adjust (Decl : Node_Id) is - Id : constant Entity_Id := Defining_Identifier (Decl); - Typ : constant Entity_Id := Etype (Id); - Adj_Stmt : Node_Id; + Id : constant Entity_Id := Defining_Identifier (Decl); + Typ : constant Entity_Id := Etype (Id); + + Adj_Call : Node_Id; begin -- begin @@ -8033,7 +8089,7 @@ package body Exp_Ch7 is -- end if; -- end; - Adj_Stmt := + Adj_Call := Make_Adjust_Call ( Obj_Ref => Make_Selected_Component (Loc, @@ -8041,19 +8097,32 @@ package body Exp_Ch7 is Selector_Name => Make_Identifier (Loc, Chars (Id))), Typ => Typ); - if Exceptions_OK then - Adj_Stmt := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Adj_Stmt), - Exception_Handlers => New_List ( - Build_Exception_Handler (Finalizer_Data)))); - end if; + -- Guard against a missing [Deep_]Adjust when the component + -- type was not properly frozen. + + if Present (Adj_Call) then + if Exceptions_OK then + Adj_Call := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Adj_Call), + Exception_Handlers => New_List ( + Build_Exception_Handler (Finalizer_Data)))); + end if; - Append_To (Stmts, Adj_Stmt); + Append_To (Stmts, Adj_Call); + end if; end Process_Component_For_Adjust; + -- Local variables + + Decl : Node_Id; + Decl_Id : Entity_Id; + Decl_Typ : Entity_Id; + Has_POC : Boolean; + Num_Comps : Nat; + -- Start of processing for Process_Component_List_For_Adjust begin @@ -8389,7 +8458,8 @@ package body Exp_Ch7 is Exceptions_OK : constant Boolean := not Restriction_Active (No_Exception_Propagation); Loc : constant Source_Ptr := Sloc (Typ); - Typ_Def : constant Node_Id := Type_Definition (Parent (Typ)); + Typ_Def : constant Node_Id := + Type_Definition (Parent (Typ)); Bod_Stmts : List_Id; Counter : Int := 0; @@ -8447,7 +8517,7 @@ package body Exp_Ch7 is is Id : constant Entity_Id := Defining_Identifier (Decl); Typ : constant Entity_Id := Etype (Id); - Fin_Stmt : Node_Id; + Fin_Call : Node_Id; begin if Is_Local then @@ -8511,7 +8581,7 @@ package body Exp_Ch7 is -- end if; -- end; - Fin_Stmt := + Fin_Call := Make_Final_Call (Obj_Ref => Make_Selected_Component (Loc, @@ -8519,17 +8589,22 @@ package body Exp_Ch7 is Selector_Name => Make_Identifier (Loc, Chars (Id))), Typ => Typ); - if not Restriction_Active (No_Exception_Propagation) then - Fin_Stmt := - Make_Block_Statement (Loc, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Fin_Stmt), - Exception_Handlers => New_List ( - Build_Exception_Handler (Finalizer_Data)))); - end if; + -- Guard against a missing [Deep_]Finalize when the component + -- type was not properly frozen. + + if Present (Fin_Call) then + if Exceptions_OK then + Fin_Call := + Make_Block_Statement (Loc, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Fin_Call), + Exception_Handlers => New_List ( + Build_Exception_Handler (Finalizer_Data)))); + end if; - Append_To (Stmts, Fin_Stmt); + Append_To (Stmts, Fin_Call); + end if; end Process_Component_For_Finalize; -- Start of processing for Process_Component_List_For_Finalize @@ -9061,17 +9136,18 @@ package body Exp_Ch7 is Utyp : Entity_Id; begin + Ref := Obj_Ref; + -- Recover the proper type which contains [Deep_]Finalize if Is_Class_Wide_Type (Typ) then Utyp := Root_Type (Typ); Atyp := Utyp; - Ref := Obj_Ref; elsif Is_Concurrent_Type (Typ) then Utyp := Corresponding_Record_Type (Typ); Atyp := Empty; - Ref := Convert_Concurrent (Obj_Ref, Typ); + Ref := Convert_Concurrent (Ref, Typ); elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) @@ -9079,12 +9155,11 @@ package body Exp_Ch7 is then Utyp := Corresponding_Record_Type (Full_View (Typ)); Atyp := Typ; - Ref := Convert_Concurrent (Obj_Ref, Full_View (Typ)); + Ref := Convert_Concurrent (Ref, Full_View (Typ)); else Utyp := Typ; Atyp := Typ; - Ref := Obj_Ref; end if; Utyp := Underlying_Type (Base_Type (Utyp)); @@ -9113,7 +9188,8 @@ package body Exp_Ch7 is -- their parents. In this case, [Deep_]Finalize can be found in the full -- view of the parent type. - if Is_Tagged_Type (Utyp) + if Present (Utyp) + and then Is_Tagged_Type (Utyp) and then Is_Derived_Type (Utyp) and then Is_Empty_Elmt_List (Primitive_Operations (Utyp)) and then Is_Private_Type (Etype (Utyp)) @@ -9127,7 +9203,7 @@ package body Exp_Ch7 is -- When dealing with the completion of a private type, use the base type -- instead. - if Utyp /= Base_Type (Utyp) then + if Present (Utyp) and then Utyp /= Base_Type (Utyp) then pragma Assert (Present (Atyp) and then Is_Private_Type (Atyp)); Utyp := Base_Type (Utyp); @@ -9135,7 +9211,14 @@ package body Exp_Ch7 is Set_Assignment_OK (Ref); end if; - if Skip_Self then + -- The underlying type may not be present due to a missing full view. In + -- this case freezing did not take place and there is no [Deep_]Finalize + -- primitive to call. + + if No (Utyp) then + return Empty; + + elsif Skip_Self then if Has_Controlled_Component (Utyp) then if Is_Tagged_Type (Utyp) then Fin_Id := Find_Optional_Prim_Op (Utyp, TSS_Deep_Finalize); @@ -9215,7 +9298,7 @@ package body Exp_Ch7 is return Make_Call (Loc, Proc_Id => Fin_Id, - Param => New_Copy_Tree (Ref), + Param => Ref, Skip_Self => Skip_Self); else return Empty; @@ -9310,18 +9393,21 @@ package body Exp_Ch7 is --------------------------------- function Make_Finalize_Address_Stmts (Typ : Entity_Id) return List_Id is - Loc : constant Source_Ptr := Sloc (Typ); - Ptr_Typ : constant Entity_Id := Make_Temporary (Loc, 'P'); - Decls : List_Id; - Desg_Typ : Entity_Id; - Obj_Expr : Node_Id; + Loc : constant Source_Ptr := Sloc (Typ); + + Decls : List_Id; + Desig_Typ : Entity_Id; + Fin_Block : Node_Id; + Fin_Call : Node_Id; + Obj_Expr : Node_Id; + Ptr_Typ : Entity_Id; begin if Is_Array_Type (Typ) then if Is_Constrained (First_Subtype (Typ)) then - Desg_Typ := First_Subtype (Typ); + Desig_Typ := First_Subtype (Typ); else - Desg_Typ := Base_Type (Typ); + Desig_Typ := Base_Type (Typ); end if; -- Class-wide types of constrained root types @@ -9353,26 +9439,28 @@ package body Exp_Ch7 is Parent_Typ := Underlying_Record_View (Parent_Typ); end if; - Desg_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ)); + Desig_Typ := Class_Wide_Type (Underlying_Type (Parent_Typ)); end; -- General case else - Desg_Typ := Typ; + Desig_Typ := Typ; end if; -- Generate: -- type Ptr_Typ is access all Typ; -- for Ptr_Typ'Storage_Size use 0; + Ptr_Typ := Make_Temporary (Loc, 'P'); + Decls := New_List ( Make_Full_Type_Declaration (Loc, Defining_Identifier => Ptr_Typ, Type_Definition => Make_Access_To_Object_Definition (Loc, All_Present => True, - Subtype_Indication => New_Occurrence_Of (Desg_Typ, Loc))), + Subtype_Indication => New_Occurrence_Of (Desig_Typ, Loc))), Make_Attribute_Definition_Clause (Loc, Name => New_Occurrence_Of (Ptr_Typ, Loc), @@ -9405,7 +9493,7 @@ package body Exp_Ch7 is -- Generate: -- Dnn : constant Storage_Offset := - -- Desg_Typ'Descriptor_Size / Storage_Unit; + -- Desig_Typ'Descriptor_Size / Storage_Unit; Dope_Id := Make_Temporary (Loc, 'D'); @@ -9419,7 +9507,7 @@ package body Exp_Ch7 is Make_Op_Divide (Loc, Left_Opnd => Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Desg_Typ, Loc), + Prefix => New_Occurrence_Of (Desig_Typ, Loc), Attribute_Name => Name_Descriptor_Size), Right_Opnd => Make_Integer_Literal (Loc, System_Storage_Unit)))); @@ -9442,20 +9530,30 @@ package body Exp_Ch7 is end; end if; - -- Create the block and the finalization call + Fin_Call := + Make_Final_Call ( + Obj_Ref => + Make_Explicit_Dereference (Loc, + Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)), + Typ => Desig_Typ); - return New_List ( - Make_Block_Statement (Loc, - Declarations => Decls, + if Present (Fin_Call) then + Fin_Block := + Make_Block_Statement (Loc, + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Fin_Call))); - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List ( - Make_Final_Call ( - Obj_Ref => - Make_Explicit_Dereference (Loc, - Prefix => Unchecked_Convert_To (Ptr_Typ, Obj_Expr)), - Typ => Desg_Typ))))); + -- Otherwise previous errors or a missing full view may prevent the + -- proper freezing of the designated type. If this is the case, there + -- is no [Deep_]Finalize primitive to call. + + else + Fin_Block := Make_Null_Statement (Loc); + end if; + + return New_List (Fin_Block); end Make_Finalize_Address_Stmts; ------------------------------------- @@ -9530,13 +9628,15 @@ package body Exp_Ch7 is Utyp : Entity_Id; begin + Ref := Obj_Ref; + -- Deal with the type and object reference. Depending on the context, an -- object reference may need several conversions. if Is_Concurrent_Type (Typ) then Is_Conc := True; Utyp := Corresponding_Record_Type (Typ); - Ref := Convert_Concurrent (Obj_Ref, Typ); + Ref := Convert_Concurrent (Ref, Typ); elsif Is_Private_Type (Typ) and then Present (Full_View (Typ)) @@ -9544,17 +9644,15 @@ package body Exp_Ch7 is then Is_Conc := True; Utyp := Corresponding_Record_Type (Underlying_Type (Typ)); - Ref := Convert_Concurrent (Obj_Ref, Underlying_Type (Typ)); + Ref := Convert_Concurrent (Ref, Underlying_Type (Typ)); else Is_Conc := False; Utyp := Typ; - Ref := Obj_Ref; end if; - Set_Assignment_OK (Ref); - Utyp := Underlying_Type (Base_Type (Utyp)); + Set_Assignment_OK (Ref); -- Deal with untagged derivation of private views @@ -9571,12 +9669,20 @@ package body Exp_Ch7 is -- completion of a private type. We need to access the base type and -- generate a conversion to it. - if Utyp /= Base_Type (Utyp) then + if Present (Utyp) and then Utyp /= Base_Type (Utyp) then pragma Assert (Is_Private_Type (Typ)); Utyp := Base_Type (Utyp); Ref := Unchecked_Convert_To (Utyp, Ref); end if; + -- The underlying type may not be present due to a missing full view. + -- In this case freezing did not take place and there is no suitable + -- [Deep_]Initialize primitive to call. + + if No (Utyp) then + return Empty; + end if; + -- Select the appropriate version of initialize if Has_Controlled_Component (Utyp) then @@ -9596,8 +9702,7 @@ package body Exp_Ch7 is return Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Proc, Loc), + Name => New_Occurrence_Of (Proc, Loc), Parameter_Associations => New_List (Ref)); end Make_Init_Call; diff --git a/gcc/ada/exp_ch7.ads b/gcc/ada/exp_ch7.ads index ed65416..0db3df5 100644 --- a/gcc/ada/exp_ch7.ads +++ b/gcc/ada/exp_ch7.ads @@ -184,10 +184,11 @@ package Exp_Ch7 is Typ : Entity_Id; Skip_Self : Boolean := False) return Node_Id; -- Create a call to either Adjust or Deep_Adjust depending on the structure - -- of type Typ. Obj_Ref is an expression with no-side effect (not required + -- of type Typ. Obj_Ref is an expression with no side effects (not required -- to have been previously analyzed) that references the object to be -- adjusted. Typ is the expected type of Obj_Ref. When Skip_Self is set, - -- only the components (if any) are adjusted. + -- only the components (if any) are adjusted. Return Empty if Adjust or + -- Deep_Adjust is not available, possibly due to previous errors. function Make_Detach_Call (Obj_Ref : Node_Id) return Node_Id; -- Create a call to unhook an object from an arbitrary list. Obj_Ref is the @@ -200,11 +201,13 @@ package Exp_Ch7 is (Obj_Ref : Node_Id; Typ : Entity_Id; Skip_Self : Boolean := False) return Node_Id; - -- Create a call to either Finalize or Deep_Finalize depending on the - -- structure of type Typ. Obj_Ref is an expression (with no-side effect + -- Create a call to either Finalize or Deep_Finalize, depending on the + -- structure of type Typ. Obj_Ref is an expression (with no side effects -- and is not required to have been previously analyzed) that references -- the object to be finalized. Typ is the expected type of Obj_Ref. When - -- Skip_Self is set, only the components (if any) are finalized. + -- Skip_Self is set, only the components (if any) are finalized. Return + -- Empty if Finalize or Deep_Finalize is not available, possibly due to + -- previous errors. procedure Make_Finalize_Address_Body (Typ : Entity_Id); -- Create the body of TSS routine Finalize_Address if Typ is controlled and @@ -215,11 +218,12 @@ package Exp_Ch7 is function Make_Init_Call (Obj_Ref : Node_Id; Typ : Entity_Id) return Node_Id; - -- Obj_Ref is an expression with no-side effect (not required to have been - -- previously analyzed) that references the object to be initialized. Typ - -- is the expected type of Obj_Ref, which is either a controlled type - -- (Is_Controlled) or a type with controlled components (Has_Controlled_ - -- Components). + -- Create a call to either Initialize or Deep_Initialize, depending on the + -- structure of type Typ. Obj_Ref is an expression with no side effects + -- (not required to have been previously analyzed) that references the + -- object to be initialized. Typ is the expected type of Obj_Ref. Return + -- Empty if Initialize or Deep_Initialize is not available, possibly due to + -- previous errors. function Make_Handler_For_Ctrl_Operation (Loc : Source_Ptr) return Node_Id; -- Generate an implicit exception handler with an 'others' choice, diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index cfedf75..8ca30b3 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -11934,12 +11934,12 @@ package body Exp_Ch9 is -- Add the _Secondary_Stack_Size component if a Secondary_Stack_Size -- rep item is present. - if Has_Rep_Item (TaskId, Name_Secondary_Stack_Size, - Check_Parents => False) + if Has_Rep_Item + (TaskId, Name_Secondary_Stack_Size, Check_Parents => False) then Append_To (Cdecls, Make_Component_Declaration (Loc, - Defining_Identifier => + Defining_Identifier => Make_Defining_Identifier (Loc, Name_uSecondary_Stack_Size), Component_Definition => @@ -14149,8 +14149,8 @@ package body Exp_Ch9 is if Restriction_Active (No_Secondary_Stack) then Append_To (Args, Make_Integer_Literal (Loc, 0)); - elsif Has_Rep_Item (Ttyp, Name_Secondary_Stack_Size, - Check_Parents => False) + elsif Has_Rep_Item + (Ttyp, Name_Secondary_Stack_Size, Check_Parents => False) then Append_To (Args, Make_Selected_Component (Loc, diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index f19b6e3..d400041 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -2943,7 +2943,10 @@ package body Exp_Util is Set_Etype (Obj_Ref, Desig_Typ); end if; - Fin_Call := Make_Final_Call (Obj_Ref, Desig_Typ); + Fin_Call := + Make_Final_Call + (Obj_Ref => Obj_Ref, + Typ => Desig_Typ); -- Otherwise finalize the hook. Generate: diff --git a/gcc/ada/s-tarest.adb b/gcc/ada/s-tarest.adb index 6b71c09..936e5fe 100644 --- a/gcc/ada/s-tarest.adb +++ b/gcc/ada/s-tarest.adb @@ -217,6 +217,10 @@ package body System.Tasking.Restricted.Stages is -- Create_TSD and thus the function returns 0 to suppress the -- creation of the fixed secondary stack in the primary stack. + -------------------------- + -- Secondary_Stack_Size -- + -------------------------- + function Secondary_Stack_Size return Storage_Elements.Storage_Offset is use System.Storage_Elements; use System.Secondary_Stack; @@ -263,6 +267,8 @@ package body System.Tasking.Restricted.Stages is -- execution of its task body, then EO will contain the associated -- exception occurrence. Otherwise, it will contain Null_Occurrence. + -- Start of processing for Task_Wrapper + begin if not Parameters.Sec_Stack_Dynamic then Self_ID.Common.Compiler_Data.Sec_Stack_Addr := @@ -270,8 +276,8 @@ package body System.Tasking.Restricted.Stages is SST.SS_Init (Secondary_Stack_Address, Integer (Secondary_Stack'Last)); end if; - -- Initialize low-level TCB components, that - -- cannot be initialized by the creator. + -- Initialize low-level TCB components, that cannot be initialized by + -- the creator. Enter_Task (Self_ID); diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 64ec3b1..7e0bdcb 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -1050,6 +1050,10 @@ package body System.Tasking.Stages is -- Create_TSD and thus the function returns 0 to suppress the -- creation of the fixed secondary stack in the primary stack. + -------------------------- + -- Secondary_Stack_Size -- + -------------------------- + function Secondary_Stack_Size return Storage_Elements.Storage_Offset is use System.Storage_Elements; use System.Secondary_Stack; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 16904ca..d7c7683 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -1036,9 +1036,16 @@ package body Sem_Attr is Set_Never_Set_In_Source (Ent, False); end if; - -- Mark entity as address taken, and kill current values + -- Mark entity as address taken in the case of + -- 'Unrestricted_Access or subprograms, and kill current + -- values. + + if Aname = Name_Unrestricted_Access + or else Is_Subprogram (Ent) + then + Set_Address_Taken (Ent); + end if; - Set_Address_Taken (Ent); Kill_Current_Values (Ent); exit; @@ -1053,7 +1060,7 @@ package body Sem_Attr is end loop; end; - -- Check for aliased view.. We allow a nonaliased prefix when within + -- Check for aliased view. We allow a nonaliased prefix when within -- an instance because the prefix may have been a tagged formal -- object, which is defined to be aliased even when the actual -- might not be (other instance cases will have been caught in the @@ -11027,9 +11034,13 @@ package body Sem_Attr is end; end if; - -- Mark that address of entity is taken + -- Mark that address of entity is taken in case of + -- 'Unrestricted_Access or in case of a subprogram. - if Is_Entity_Name (P) then + if Is_Entity_Name (P) + and then (Attr_Id = Attribute_Unrestricted_Access + or else Is_Subprogram (Entity (P))) + then Set_Address_Taken (Entity (P)); end if; diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index 5681396..264a284 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -2532,21 +2532,7 @@ package body Sem_Ch10 is Set_Analyzed (N); end if; - -- If the library unit is a predefined unit, and we are in high - -- integrity mode, then temporarily reset Configurable_Run_Time_Mode - -- for the analysis of the with'ed unit. This mode does not prevent - -- explicit with'ing of run-time units. - - if Configurable_Run_Time_Mode - and then Is_Predefined_File_Name (Unit_File_Name (Get_Source_Unit (U))) - then - Configurable_Run_Time_Mode := False; - Semantics (Library_Unit (N)); - Configurable_Run_Time_Mode := True; - - else - Semantics (Library_Unit (N)); - end if; + Semantics (Library_Unit (N)); Intunit := Is_Internal_File_Name (Unit_File_Name (Current_Sem_Unit)); diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 2ff1665..7a23005 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2063,10 +2063,10 @@ package body Sem_Ch13 is Aspect_Output | Aspect_Read | Aspect_Scalar_Storage_Order | - Aspect_Size | - Aspect_Small | Aspect_Secondary_Stack_Size | Aspect_Simple_Storage_Pool | + Aspect_Size | + Aspect_Small | Aspect_Storage_Pool | Aspect_Stream_Size | Aspect_Value_Size | @@ -5708,8 +5708,8 @@ package body Sem_Ch13 is if From_Aspect_Specification (N) then if not Is_Task_Type (U_Ent) then - Error_Msg_N ("Secondary Stack Size can only be " & - "defined for task", Nam); + Error_Msg_N + ("Secondary Stack Size can only be defined for task", Nam); elsif Duplicate_Clause then null; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 6bf680f..37c206e 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -11828,33 +11828,30 @@ package body Sem_Prag is -- processing is required here. when Pragma_Assertion_Policy => Assertion_Policy : declare - procedure Resolve_Suppressible (Policy : Node_Id); -- Converts the assertion policy 'Suppressible' to either Check or - -- Ignore based on whether checks are suppressed via -gnatp or ??? + -- Ignore based on whether checks are suppressed via -gnatp. -------------------------- -- Resolve_Suppressible -- -------------------------- procedure Resolve_Suppressible (Policy : Node_Id) is + Arg : constant Node_Id := Get_Pragma_Arg (Policy); Nam : Name_Id; - ARG : constant Node_Id := Get_Pragma_Arg (Policy); begin - if Chars (Expression (Policy)) = Name_Suppressible then - - -- Rewrite the policy argument node to either Ignore or - -- Check. This is done because the argument is referenced - -- directly later during analysis. + -- Transform policy argument Suppressible into either Ignore or + -- Check depending on whether checks are enabled or suppressed. + if Chars (Arg) = Name_Suppressible then if Suppress_Checks then Nam := Name_Ignore; else Nam := Name_Check; end if; - Rewrite (ARG, Make_Identifier (Sloc (ARG), Nam)); + Rewrite (Arg, Make_Identifier (Sloc (Arg), Nam)); end if; end Resolve_Suppressible; @@ -20608,9 +20605,8 @@ package body Sem_Prag is Arg := Get_Pragma_Arg (Arg1); Ent := Defining_Identifier (Parent (P)); - -- The expression must be analyzed in the special - -- manner described in "Handling of Default Expressions" - -- in sem.ads. + -- The expression must be analyzed in the special manner + -- described in "Handling of Default Expressions" in sem.ads. Preanalyze_Spec_Expression (Arg, Any_Integer); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a4e733a..33266b3 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -20658,14 +20658,17 @@ package body Sem_Util is when Entry_Kind => if Nkind (Parent (E)) = N_Entry_Body then declare - Prot_Type : Entity_Id; Prot_Item : Entity_Id; + Prot_Type : Entity_Id; + begin if Ekind (E) = E_Entry then Prot_Type := Scope (E); + + -- Bodies of entry families are nested within an extra scope + -- that contains an entry index declaration + else - -- Bodies of entry families are nested within an extra - -- scope that contains an entry index declaration. Prot_Type := Scope (Scope (E)); end if; |