From bdc193bad16766de82346ac6191a49e0771662c6 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 1 Aug 2014 16:35:44 +0200 Subject: [PATCH] [multiple changes] 2014-08-01 Bob Duff * gnat_ugn.texi: Minor updates. 2014-08-01 Robert Dewar * atree.adb: Minor reformatting. 2014-08-01 Ed Schonberg * exp_aggr.adb (Init_Hidden_Discriminants): If some ancestor is a private extension, get stored constraint, if any, from full view. From-SVN: r213479 --- gcc/ada/ChangeLog | 13 +++ gcc/ada/atree.adb | 19 +++-- gcc/ada/exp_aggr.adb | 183 ++++++++++++++++++++++-------------------- gcc/ada/gnat_ugn.texi | 13 ++- 4 files changed, 121 insertions(+), 107 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6b32f982249..c4654d130cd 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2014-08-01 Bob Duff + + * gnat_ugn.texi: Minor updates. + +2014-08-01 Robert Dewar + + * atree.adb: Minor reformatting. + +2014-08-01 Ed Schonberg + + * exp_aggr.adb (Init_Hidden_Discriminants): If some ancestor is a + private extension, get stored constraint, if any, from full view. + 2014-08-01 Robert Dewar * opt.ads (No_Elab_Code_All_Pragma): New global variable. diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb index 19517734867..2af7e2e48b9 100644 --- a/gcc/ada/atree.adb +++ b/gcc/ada/atree.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- -- -- GNAT 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- -- @@ -1800,18 +1800,17 @@ package body Atree is New_Node := New_Copy (Source); Fix_Parents (Ref_Node => Source, Fix_Node => New_Node); - -- We now set the parent of the new node to be the same as the - -- parent of the source. Almost always this parent will be - -- replaced by a new value when the relocated node is reattached - -- to the tree, but by doing it now, we ensure that this node is - -- not even temporarily disconnected from the tree. Note that this - -- does not happen free, because in the list case, the parent does - -- not get set. + -- We now set the parent of the new node to be the same as the parent of + -- the source. Almost always this parent will be replaced by a new value + -- when the relocated node is reattached to the tree, but by doing it + -- now, we ensure that this node is not even temporarily disconnected + -- from the tree. Note that this does not happen free, because in the + -- list case, the parent does not get set. Set_Parent (New_Node, Parent (Source)); - -- If the node being relocated was a rewriting of some original - -- node, then the relocated node has the same original node. + -- If the node being relocated was a rewriting of some original node, + -- then the relocated node has the same original node. if Orig_Nodes.Table (Source) /= Source then Orig_Nodes.Table (New_Node) := Orig_Nodes.Table (Source); diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 0214a6b2378..378d66fee63 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -2132,10 +2132,19 @@ package body Exp_Aggr is Disc := First_Discriminant (Parent_Type); - -- We know that one of the stored-constraint lists is present. + -- We know that one of the stored-constraint lists is present if Present (Stored_Constraint (Btype)) then Discr_Val := First_Elmt (Stored_Constraint (Btype)); + + -- For private extension, stored constraint may be on full view + + elsif Is_Private_Type (Btype) + and then Present (Full_View (Btype)) + and then Present (Stored_Constraint (Full_View (Btype))) + then + Discr_Val := First_Elmt (Stored_Constraint (Full_View (Btype))); + else Discr_Val := First_Elmt (Stored_Constraint (Typ)); end if; @@ -2197,10 +2206,10 @@ package body Exp_Aggr is Finalization_Done := True; -- Determine the external finalization list. It is either the - -- finalization list of the outer-scope or the one coming from - -- an outer aggregate. When the target is not a temporary, the - -- proper scope is the scope of the target rather than the - -- potentially transient current scope. + -- finalization list of the outer-scope or the one coming from an + -- outer aggregate. When the target is not a temporary, the proper + -- scope is the scope of the target rather than the potentially + -- transient current scope. if Is_Controlled (Typ) and then Ancestor_Is_Subtype_Mark then Ref := Convert_To (Init_Typ, New_Copy_Tree (Target)); @@ -2433,6 +2442,7 @@ package body Exp_Aggr is -- in the limited case, the ancestor part must be either a -- function call (possibly qualified, or wrapped in an unchecked -- conversion) or aggregate (definitely qualified). + -- The ancestor part can also be a function call (that may be -- transformed into an explicit dereference) or a qualification -- of one such. @@ -3009,10 +3019,10 @@ package body Exp_Aggr is Next (Comp); end loop; - -- If the type is tagged, the tag needs to be initialized (unless - -- compiling for the Java VM where tags are implicit). It is done - -- late in the initialization process because in some cases, we call - -- the init proc of an ancestor which will not leave out the right tag + -- If the type is tagged, the tag needs to be initialized (unless we + -- are in VM-mode where tags are implicit). It is done late in the + -- initialization process because in some cases, we call the init + -- proc of an ancestor which will not leave out the right tag. if Ancestor_Is_Expression then null; @@ -3042,7 +3052,7 @@ package body Exp_Aggr is Append_To (L, Instr); - -- Ada 2005 (AI-251): If the tagged type has been derived from + -- Ada 2005 (AI-251): If the tagged type has been derived from an -- abstract interfaces we must also initialize the tags of the -- secondary dispatch tables. @@ -3378,16 +3388,16 @@ package body Exp_Aggr is or else (Parent_Kind = N_Assignment_Statement and then Inside_Init_Proc) - -- (Ada 2005) An inherently limited type in a return statement, - -- which will be handled in a build-in-place fashion, and may be - -- rewritten as an extended return and have its own finalization - -- machinery. In the case of a simple return, the aggregate needs - -- to be delayed until the scope for the return statement has been - -- created, so that any finalization chain will be associated with - -- that scope. For extended returns, we delay expansion to avoid the - -- creation of an unwanted transient scope that could result in - -- premature finalization of the return object (which is built in - -- in place within the caller's scope). + -- (Ada 2005) An inherently limited type in a return statement, which + -- will be handled in a build-in-place fashion, and may be rewritten + -- as an extended return and have its own finalization machinery. + -- In the case of a simple return, the aggregate needs to be delayed + -- until the scope for the return statement has been created, so + -- that any finalization chain will be associated with that scope. + -- For extended returns, we delay expansion to avoid the creation + -- of an unwanted transient scope that could result in premature + -- finalization of the return object (which is built in in place + -- within the caller's scope). or else (Is_Limited_View (Typ) @@ -3404,9 +3414,9 @@ package body Exp_Aggr is end if; -- If the aggregate is non-limited, create a temporary. If it is limited - -- and the context is an assignment, this is a subaggregate for an - -- enclosing aggregate being expanded. It must be built in place, so use - -- the target of the current assignment. + -- and context is an assignment, this is a subaggregate for an enclosing + -- aggregate being expanded. It must be built in place, so use target of + -- the current assignment. if Is_Limited_Type (Typ) and then Nkind (Parent (N)) = N_Assignment_Statement @@ -3491,6 +3501,8 @@ package body Exp_Aggr is -- Check_Static_Components -- ----------------------------- + -- Could use some comments in this body ??? + procedure Check_Static_Components is Expr : Node_Id; @@ -3777,15 +3789,16 @@ package body Exp_Aggr is else Choice_Index := UI_To_Int (Expr_Value (Choice)); + if Choice_Index in Vals'Range then Vals (Choice_Index) := New_Copy_Tree (Expression (Elmt)); goto Continue; - else - -- Choice is statically out-of-range, will be - -- rewritten to raise Constraint_Error. + -- Choice is statically out-of-range, will be + -- rewritten to raise Constraint_Error. + else return False; end if; end if; @@ -3798,6 +3811,7 @@ package body Exp_Aggr is not Compile_Time_Known_Value (Hi) then return False; + else for J in UI_To_Int (Expr_Value (Lo)) .. UI_To_Int (Expr_Value (Hi)) @@ -4175,7 +4189,8 @@ package body Exp_Aggr is end if; Remainder := Value rem 2**System_Storage_Unit; - for I in 1 .. Nunits - 1 loop + + for J in 1 .. Nunits - 1 loop Value := Value / 2**System_Storage_Unit; if Value rem 2**System_Storage_Unit /= Remainder then @@ -4240,7 +4255,7 @@ package body Exp_Aggr is Decl := Make_Full_Type_Declaration (Loc, Defining_Identifier => Agg_Type, - Type_Definition => + Type_Definition => Make_Constrained_Array_Definition (Loc, Discrete_Subtype_Definitions => Indexes, Component_Definition => @@ -4274,7 +4289,7 @@ package body Exp_Aggr is Get_Index_Bounds (Index_Bounds, Ind_Lo, Ind_Hi); -- Generate the following test: - -- + -- [constraint_error when -- Aggr_Lo <= Aggr_Hi and then -- (Aggr_Lo < Ind_Lo or else Aggr_Hi > Ind_Hi)] @@ -4364,8 +4379,7 @@ package body Exp_Aggr is if Index_Checks_Suppressed (Ind_Typ) then Cond := Empty; - elsif Dim = 1 - or else (Aggr_Lo = Sub_Lo and then Aggr_Hi = Sub_Hi) + elsif Dim = 1 or else (Aggr_Lo = Sub_Lo and then Aggr_Hi = Sub_Hi) then Cond := Empty; @@ -4588,12 +4602,12 @@ package body Exp_Aggr is -- Start of processing for Safe_Component begin - -- If the component appears in an association that may - -- correspond to more than one element, it is not analyzed - -- before the expansion into assignments, to avoid side effects. - -- We analyze, but do not resolve the copy, to obtain sufficient - -- entity information for the checks that follow. If component is - -- overloaded we assume an unsafe function call. + -- If the component appears in an association that may correspond + -- to more than one element, it is not analyzed before expansion + -- into assignments, to avoid side effects. We analyze, but do not + -- resolve the copy, to obtain sufficient entity information for + -- the checks that follow. If component is overloaded we assume + -- an unsafe function call. if not Analyzed (Comp) then if Is_Overloaded (Expr) then @@ -4632,9 +4646,9 @@ package body Exp_Aggr is -- assignment in place unless the bounds of the aggregate are -- statically equal to those of the target. - -- If the aggregate is given by an others choice, the bounds - -- are derived from the left-hand side, and the assignment is - -- safe if the expression is. + -- If the aggregate is given by an others choice, the bounds are + -- derived from the left-hand side, and the assignment is safe if + -- the expression is. if Is_Others_Aggregate (N) then return @@ -4648,8 +4662,8 @@ package body Exp_Aggr is Obj_In := First_Index (Etype (Name (Parent (N)))); else - -- Context is an allocator. Check bounds of aggregate - -- against given type in qualified expression. + -- Context is an allocator. Check bounds of aggregate against + -- given type in qualified expression. pragma Assert (Nkind (Parent (Parent (N))) = N_Allocator); Obj_In := @@ -4733,6 +4747,8 @@ package body Exp_Aggr is -- Count the number of discrete choices. Start with -1 because -- the others choice does not count. + -- Is there some reason we do not use List_Length here ??? + Nb_Choices := -1; Assoc := First (Component_Associations (Sub_Aggr)); while Present (Assoc) loop @@ -4834,7 +4850,7 @@ package body Exp_Aggr is Expressions => New_List (Duplicate_Subexpr_Move_Checks (Aggr_Lo))), - Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)), + Right_Opnd => Make_Integer_Literal (Loc, Nb_Elements - 1)), Right_Opnd => Make_Attribute_Reference (Loc, @@ -4854,17 +4870,13 @@ package body Exp_Aggr is Make_Or_Else (Loc, Left_Opnd => Make_Op_Lt (Loc, - Left_Opnd => - Duplicate_Subexpr_Move_Checks (Choices_Lo), - Right_Opnd => - Duplicate_Subexpr_Move_Checks (Aggr_Lo)), + Left_Opnd => Duplicate_Subexpr_Move_Checks (Choices_Lo), + Right_Opnd => Duplicate_Subexpr_Move_Checks (Aggr_Lo)), Right_Opnd => Make_Op_Gt (Loc, - Left_Opnd => - Duplicate_Subexpr (Choices_Hi), - Right_Opnd => - Duplicate_Subexpr (Aggr_Hi))); + Left_Opnd => Duplicate_Subexpr (Choices_Hi), + Right_Opnd => Duplicate_Subexpr (Aggr_Hi))); end if; if Present (Cond) then @@ -5027,12 +5039,12 @@ package body Exp_Aggr is Compute_Others_Present (N, 1); for J in 1 .. Aggr_Dimension loop - -- There is no need to emit a check if an others choice is - -- present for this array aggregate dimension since in this - -- case one of N's sub-aggregates has taken its bounds from the - -- context and these bounds must have been checked already. In - -- addition all sub-aggregates corresponding to the same - -- dimension must all have the same bounds (checked in (c) below). + -- There is no need to emit a check if an others choice is present + -- for this array aggregate dimension since in this case one of + -- N's sub-aggregates has taken its bounds from the context and + -- these bounds must have been checked already. In addition all + -- sub-aggregates corresponding to the same dimension must all + -- have the same bounds (checked in (c) below). if not Range_Checks_Suppressed (Etype (Index_Constraint)) and then not Others_Present (J) @@ -5261,8 +5273,8 @@ package body Exp_Aggr is (Nkind (Parent (N)) = N_Assignment_Statement and then In_Place_Assign_OK) - or else - (Nkind (Parent (Parent (N))) = N_Allocator + or else + (Nkind (Parent (Parent (N))) = N_Allocator and then In_Place_Assign_OK); end if; @@ -5365,10 +5377,9 @@ package body Exp_Aggr is Maybe_In_Place_OK := False; Tmp := Make_Temporary (Loc, 'A', N); Tmp_Decl := - Make_Object_Declaration - (Loc, - Defining_Identifier => Tmp, - Object_Definition => New_Occurrence_Of (Typ, Loc)); + Make_Object_Declaration (Loc, + Defining_Identifier => Tmp, + Object_Definition => New_Occurrence_Of (Typ, Loc)); Set_No_Initialization (Tmp_Decl, True); -- If we are within a loop, the temporary will be pushed on the @@ -5398,7 +5409,6 @@ package body Exp_Aggr is Target := New_Occurrence_Of (Tmp, Loc); else - if Has_Default_Init_Comps (N) then -- Ada 2005 (AI-287): This case has not been analyzed??? @@ -5606,6 +5616,7 @@ package body Exp_Aggr is Expand_Array_Aggregate (N); end if; + exception when RE_Not_Available => return; @@ -5887,11 +5898,11 @@ package body Exp_Aggr is -- Start of processing for Expand_Record_Aggregate begin - -- If the aggregate is to be assigned to an atomic variable, we - -- have to prevent a piecemeal assignment even if the aggregate - -- is to be expanded. We create a temporary for the aggregate, and - -- assign the temporary instead, so that the back end can generate - -- an atomic move for it. + -- If the aggregate is to be assigned to an atomic variable, we have + -- to prevent a piecemeal assignment even if the aggregate is to be + -- expanded. We create a temporary for the aggregate, and assign the + -- temporary instead, so that the back end can generate an atomic move + -- for it. if Is_Atomic (Typ) and then Comes_From_Source (Parent (N)) @@ -6054,9 +6065,9 @@ package body Exp_Aggr is New_List (New_Occurrence_Of (Discriminant, Loc)), Expression => - New_Copy_Tree ( - Get_Discriminant_Value ( - Discriminant, + New_Copy_Tree + (Get_Discriminant_Value + (Discriminant, Typ, Discriminant_Constraint (Typ)))); @@ -6081,8 +6092,7 @@ package body Exp_Aggr is Comp := First_Comp; Next (First_Comp); - if Ekind (Entity - (First (Choices (Comp)))) = E_Discriminant + if Ekind (Entity (First (Choices (Comp)))) = E_Discriminant then Remove (Comp); Num_Disc := Num_Disc + 1; @@ -6120,8 +6130,8 @@ package body Exp_Aggr is New_Copy_Tree (Get_Discriminant_Value (Discriminant, - Typ, - Discriminant_Constraint (Typ))); + Typ, + Discriminant_Constraint (Typ))); Append (New_Comp, Constraints); Next_Stored_Discriminant (Discriminant); end loop; @@ -6129,11 +6139,11 @@ package body Exp_Aggr is Decl := Make_Subtype_Declaration (Loc, Defining_Identifier => Make_Temporary (Loc, 'T'), - Subtype_Indication => + Subtype_Indication => Make_Subtype_Indication (Loc, Subtype_Mark => New_Occurrence_Of (Etype (Base_Type (Typ)), Loc), - Constraint => + Constraint => Make_Index_Or_Discriminant_Constraint (Loc, Constraints))); @@ -6175,18 +6185,16 @@ package body Exp_Aggr is -- Skip all expander-generated components - if - not Comes_From_Source (Original_Record_Component (Comp)) + if not Comes_From_Source (Original_Record_Component (Comp)) then null; else New_Comp := Make_Selected_Component (Loc, - Prefix => + Prefix => Unchecked_Convert_To (Typ, Duplicate_Subexpr (Parent_Expr, True)), - Selector_Name => New_Occurrence_Of (Comp, Loc)); Append_To (Comps, @@ -6311,6 +6319,7 @@ package body Exp_Aggr is Comps : constant List_Id := Component_Associations (N); C : Node_Id; Expr : Node_Id; + begin pragma Assert (Nkind_In (N, N_Aggregate, N_Extension_Aggregate)); @@ -6471,7 +6480,6 @@ package body Exp_Aggr is is begin Set_Assignment_OK (Name); - return Make_Assignment_Statement (Sloc, Name, Expression); end Make_OK_Assignment_Statement; @@ -6977,14 +6985,12 @@ package body Exp_Aggr is Incr := +Comp_Size; end if; - Shift := Init_Shift; - One_Dim := First (Expressions (N)); - -- Iterate over each subaggregate + Shift := Init_Shift; + One_Dim := First (Expressions (N)); while Present (One_Dim) loop One_Comp := First (Expressions (One_Dim)); - while Present (One_Comp) loop if Packed_Num = Byte_Size / Comp_Size then @@ -7026,8 +7032,7 @@ package body Exp_Aggr is Unchecked_Convert_To (Typ, Make_Qualified_Expression (Loc, Subtype_Mark => New_Occurrence_Of (Packed_Array, Loc), - Expression => - Make_Aggregate (Loc, Expressions => Comps)))); + Expression => Make_Aggregate (Loc, Expressions => Comps)))); Analyze_And_Resolve (N); return True; end; diff --git a/gcc/ada/gnat_ugn.texi b/gcc/ada/gnat_ugn.texi index fb844521ec2..5293eab3050 100644 --- a/gcc/ada/gnat_ugn.texi +++ b/gcc/ada/gnat_ugn.texi @@ -14140,10 +14140,9 @@ tool argument. Incremental processing on a per-file basis. Source files are only processed if they have been modified, or if files they depend on have been modified. This is similar to the way gnatmake/gprbuild only -compiles files that need to be recompiled. Note that in this mode -@command{gnatpp} is acting in place of the compiler, so if a project -file is used, the switches set for the compiler should not be set -to switches recognized by @command{gcc}. +compiles files that need to be recompiled. A project file is required +in this mode, and the gnat driver (as in @command{gnat pretty}) is not +supported. @item --pp-off=@var{xxx} @cindex @option{--pp-off} @command{gnatpp} @@ -14577,10 +14576,8 @@ options: --incremental -- incremental processing on a per-file basis. Source files are only processed if they have been modified, or if files they depend on have been modified. This is similar to the way gnatmake/gprbuild - only compiles files that need to be recompiled. Note that in this mode - @command{gnat2xml} is acting in place of the compiler, so if a project - file is used, the switches set for the compiler should not be set - to switches recognized by @command{gcc}. + only compiles files that need to be recompiled. A project file + is required in this mode. -j@var{n} -- In @option{--incremental} mode, use @var{n} @command{gnat2xml} processes to perform XML generation in parallel. If @var{n} is 0, then -- 2.30.2