diff options
Diffstat (limited to 'gcc/ada')
| -rw-r--r-- | gcc/ada/ChangeLog | 200 | ||||
| -rw-r--r-- | gcc/ada/checks.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/contracts.adb | 103 | ||||
| -rw-r--r-- | gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst | 6 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 514 | ||||
| -rw-r--r-- | gcc/ada/exp_attr.adb | 52 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 80 | ||||
| -rw-r--r-- | gcc/ada/exp_ch5.adb | 24 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 107 | ||||
| -rw-r--r-- | gcc/ada/exp_ch7.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 148 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 18 | ||||
| -rw-r--r-- | gcc/ada/freeze.adb | 11 | ||||
| -rw-r--r-- | gcc/ada/gnat_rm.texi | 6 | ||||
| -rw-r--r-- | gcc/ada/libgnarl/s-stusta.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_attr.adb | 5 | ||||
| -rw-r--r-- | gcc/ada/sem_case.adb | 8 | ||||
| -rw-r--r-- | gcc/ada/sem_ch10.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 911 | ||||
| -rw-r--r-- | gcc/ada/sem_prag.adb | 9 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 140 |
26 files changed, 1648 insertions, 776 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 89cb7d4..b275a5c 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,203 @@ +2025-06-09 Gary Dismukes <dismukes@adacore.com> + + * sem_ch3.adb (Constrain_Index): In the case of a fixed-lower-bound index, + set Etype of the newly created itype's Scalar_Range from the index's Etype. + * sem_ch12.adb (Validate_Array_Type_Instance): If the actual subtype is + a fixed-lower-bound type, then check again the Etype of its Scalar_Range. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Analyze_Pragma): Fix conditions for legality checks on + formal type declarations. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * sem_prag.adb (Analyze_Pragma): If pragmas apply to a formal array + type, then set the flags on the base type. + +2025-06-09 Gary Dismukes <dismukes@adacore.com> + + * exp_aggr.adb (Expand_Container_Aggregate): Use the Base_Type of the + subtype provided by the context as the subtype of the temporary object + initialized by the aggregate. + +2025-06-09 Piotr Trojanek <trojanek@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): When expanding attribute + Valid, use signedness from the validated view, not from its base type. + +2025-06-09 Gary Dismukes <dismukes@adacore.com> + + * contracts.adb (Inherit_Condition): Remove Assoc_List and its uses + along with function Check_Condition, since mapping of formals will + effectively be done in Build_Class_Wide_Expression (by Replace_Entity). + * exp_util.adb (Replace_Entity): Only rewrite entity references in + function calls that qualify according to the result of calling the + new function Call_To_Parent_Dispatching_Op_Must_Be_Mapped. + (Call_To_Parent_Dispatching_Op_Must_Be_Mapped): New function that + determines whether a function call to a primitive of Par_Subp + associated tagged type needs to be mapped (according to whether + it has any actuals that reference controlling formals of the + primitive). + +2025-06-09 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Insert_Conditional_Object_Declaration): Remove Decl + formal parameter, add Typ and Const formal parameters. + (Expand_N_Case_Expression): Fix pasto in comment. Adjust call to + Insert_Conditional_Object_Declaration and tidy up surrounding code. + (Expand_N_If_Expression): Adjust couple of calls to + Insert_Conditional_Object_Declaration. + +2025-06-06 Javier Miranda <miranda@adacore.com> + + * sem_ch4.adb (Constant_Indexing_OK): Add missing support for + RM 4.1.6(13/3), and improve performance to avoid climbing more + than needed. Add documentation. + (Try_Indexing_Function): New subprogram. + (Expr_Matches_In_Formal): Added new formals. + (Handle_Selected_Component): New subprogram. + (Has_IN_Mode): New subprogram. + (Try_Container_Indexing): Add documentation, code reorganization + and extend its functionality to improve its support for prefixed + notation calls. + +2025-06-06 Eric Botcazou <ebotcazou@adacore.com> + + * sem_ch10.adb (Install_Siblings.In_Context): Add missing guard. + +2025-06-06 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch4.adb (Insert_Conditional_Object_Declaration): Make sure the + object is allocated properly by the code generator at library level. + +2025-06-06 Steve Baird <baird@adacore.com> + + * sem_ch4.adb + (Find_Unary_Types): Because we reanalyze names in an instance, + we sometimes have to take steps to filter out extraneous name + resolution candidates that happen to be visible at the point of the + instance declaration. Remove some code that appears to have been + written with this in mind. This is done for two reasons. First, the + code sometimes doesn't work (possibly because the In_Instance test + is not specific enough - it probably should be testing to see whether + we are in an instance of the particular generic in which the result + of calling Corresponding_Generic_Type was declared) and causes correct + code to be rejected. Second, the code seems to no longer be necessary + (possibly because of subsequent fixes in this area which are not + specific to unary operators). + +2025-06-06 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Expand_Record_Aggregate): Use the named form for the + second actual parameter in the call to Duplicate_Subexpr. + * exp_attr.adb (Expand_Size_Attribute): Likewise. + * exp_ch5.adb (Expand_Assign_Array): Likewise. + (Expand_Assign_Array_Bitfield): Likewise. + (Expand_Assign_Array_Bitfield_Fast): Likewise. + * exp_util.ads (Duplicate_Subexpr): Add New_Scope formal parameter. + (Duplicate_Subexpr_No_Checks): Likewise. + (Duplicate_Subexpr_Move_Checks): Likewise. + * exp_util.adb (Build_Allocate_Deallocate_Proc): Pass Proc_Id as the + actual for New_Scope in the calls to Duplicate_Subexpr_No_Checks. + (Duplicate_Subexpr): Add New_Scope formal parameter and forward it + in the call to New_Copy_Tree. + (Duplicate_Subexpr_No_Checks): Likewise. + (Duplicate_Subexpr_Move_Checks): Likewise. + +2025-06-06 Piotr Trojanek <trojanek@adacore.com> + + * checks.adb (Insert_Valid_Check): Set flag Assignment_OK in the object + declaration inserted for the validity checks. + +2025-06-05 Javier Miranda <miranda@adacore.com> + + * exp_ch7.adb (Process_Object_Declaration): Avoid generating + duplicate names for master nodes. + +2025-06-05 Steve Baird <baird@adacore.com> + + * sem_util.adb + (Side_Effect_Free_Statements): Return False if the statement list + includes an explicit (i.e. Comes_From_Source) raise statement. + +2025-06-05 Ronan Desplanques <desplanques@adacore.com> + + * exp_ch4.adb (Tagged_Membership): Fix for protected types. + +2025-06-05 Ronan Desplanques <desplanques@adacore.com> + + * exp_attr.adb (Interunit_Ref_OK): Tweak categorization of compilation + units. + +2025-06-05 Eric Botcazou <ebotcazou@adacore.com> + + * exp_aggr.adb (Build_Two_Pass_Aggr_Code): New function containing + most of the code initially present in Two_Pass_Aggregate_Expansion. + (Two_Pass_Aggregate_Expansion): Remove redundant N parameter. + Implement built-in-place expansion for (static) object declarations + and allocators, using Build_Two_Pass_Aggr_Code for the main work. + (Expand_Array_Aggregate): Adjust Two_Pass_Aggregate_Expansion call. + Replace Etype (N) by Typ in a couple of places. + * exp_ch3.adb (Expand_Freeze_Array_Type): Remove special case for + two-pass array aggregates. + (Expand_N_Object_Declaration): Do not adjust the object when it is + initialized by a two-pass array aggregate. + * exp_ch4.adb (Expand_Allocator_Expression): Apply the processing + used for container aggregates to two-pass array aggregates. + * exp_ch6.adb (Validate_Subprogram_Calls): Skip calls present in + initialization expressions of N_Object_Declaration nodes that have + No_Initialization set. + * sem_ch3.adb (Analyze_Object_Declaration): Detect the cases of an + array originally initialized by an aggregate consistently. + +2025-06-05 Viljar Indus <indus@adacore.com> + + * doc/gnat_rm/implementation_defined_attributes.rst: Update the + documentation for Valid_Value. + * sem_attr.adb (Analyze_Attribute): Reject types where + the root type originates from Standard. + * gnat_rm.texi: Regenerate. + +2025-06-05 Gary Dismukes <dismukes@adacore.com> + + * exp_aggr.adb (Two_Pass_Aggregate_Expansion): Change call to Make_Assignment + for the indexed aggregate object to call Change_Make_OK_Assignment instead. + +2025-06-05 Eric Botcazou <ebotcazou@adacore.com> + + * exp_ch6.adb (Expand_Actuals): Remove obsolete comment. + (Make_Build_In_Place_Call_In_Anonymous_Context): Always use a proper + object declaration initialized with the function call in the cases + where a temporary is needed, with Assignment_OK set on it. + * sem_util.adb (Entity_Of): Deal with rewritten function call first. + +2025-06-05 Steve Baird <baird@adacore.com> + + * exp_attr.adb (Expand_N_Attribute_Reference): When accessing the + maps declared in package Cached_Attribute_Ops, the key value + passed to Get or to Set should never be the entity node for a + subtype. Use the entity of the corresponding type declaration + instead. + +2025-06-05 Steve Baird <baird@adacore.com> + + * sem_res.adb + (Set_Mixed_Mode_Operand): If we are about to call Resolve + passing in Any_Fixed as the expected type, then instead pass in + the fixed point type of the other operand (i.e., B_Typ). + +2025-06-05 Gary Dismukes <dismukes@adacore.com> + + * sem_util.adb (Check_Function_Writable_Actuals): Add handling for + N_Iterated_Component_Association and N_Iterated_Element_Association. + Fix a typo in an RM reference (6.4.1(20/3) => 6.4.1(6.20/3)). + (Collect_Expression_Ids): New procedure factoring code for collecting + identifiers from expressions of aggregate associations. + (Handle_Association_Choices): New procedure factoring code for handling + id collection for expressions of aggregate associations with multiple + choices. Removed redundant test of Box_Present from original code. + 2025-05-05 Eric Botcazou <ebotcazou@adacore.com> PR ada/120104 diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index dcfcaa3..6a98292 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -8163,6 +8163,7 @@ package body Checks is end if; declare + Decl : Node_Id; CE : Node_Id; PV : Node_Id; Var_Id : Entity_Id; @@ -8215,12 +8216,20 @@ package body Checks is Mutate_Ekind (Var_Id, E_Variable); Set_Etype (Var_Id, Typ); - Insert_Action (Exp, + Decl := Make_Object_Declaration (Loc, Defining_Identifier => Var_Id, Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => New_Copy_Tree (Exp)), - Suppress => Validity_Check); + Expression => New_Copy_Tree (Exp)); + + -- We might be validity-checking object whose type is declared as + -- limited but completion is a scalar type. We need to explicitly + -- flag its assignment as OK, as otherwise it would be rejected by + -- the language rules. + + Set_Assignment_OK (Decl); + + Insert_Action (Exp, Decl, Suppress => Validity_Check); Set_Validated_Object (Var_Id, New_Copy_Tree (Exp)); diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index 8b94a67..e0eb26e 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -4389,10 +4389,10 @@ package body Contracts is Seen : Subprogram_List (Subps'Range) := (others => Empty); function Inherit_Condition - (Par_Subp : Entity_Id; - Subp : Entity_Id) return Node_Id; - -- Inherit the class-wide condition from Par_Subp to Subp and adjust - -- all the references to formals in the inherited condition. + (Par_Subp : Entity_Id) return Node_Id; + -- Inherit the class-wide condition from Par_Subp. Simply makes + -- a copy of the condition in preparation for later mapping of + -- referenced formals and functions by Build_Class_Wide_Expression. procedure Merge_Conditions (From : Node_Id; Into : Node_Id); -- Merge two class-wide preconditions or postconditions (the former @@ -4407,92 +4407,11 @@ package body Contracts is ----------------------- function Inherit_Condition - (Par_Subp : Entity_Id; - Subp : Entity_Id) return Node_Id - is - function Check_Condition (Expr : Node_Id) return Boolean; - -- Used in assertion to check that Expr has no reference to the - -- formals of Par_Subp. - - --------------------- - -- Check_Condition -- - --------------------- - - function Check_Condition (Expr : Node_Id) return Boolean is - Par_Formal_Id : Entity_Id; - - function Check_Entity (N : Node_Id) return Traverse_Result; - -- Check occurrence of Par_Formal_Id - - ------------------ - -- Check_Entity -- - ------------------ - - function Check_Entity (N : Node_Id) return Traverse_Result is - begin - if Nkind (N) = N_Identifier - and then Present (Entity (N)) - and then Entity (N) = Par_Formal_Id - then - return Abandon; - end if; - - return OK; - end Check_Entity; - - function Check_Expression is new Traverse_Func (Check_Entity); - - -- Start of processing for Check_Condition - - begin - Par_Formal_Id := First_Formal (Par_Subp); - - while Present (Par_Formal_Id) loop - if Check_Expression (Expr) = Abandon then - return False; - end if; - - Next_Formal (Par_Formal_Id); - end loop; - - return True; - end Check_Condition; - - -- Local variables - - Assoc_List : constant Elist_Id := New_Elmt_List; - Par_Formal_Id : Entity_Id := First_Formal (Par_Subp); - Subp_Formal_Id : Entity_Id := First_Formal (Subp); - New_Condition : Node_Id; - + (Par_Subp : Entity_Id) return Node_Id is begin - while Present (Par_Formal_Id) loop - Append_Elmt (Par_Formal_Id, Assoc_List); - Append_Elmt (Subp_Formal_Id, Assoc_List); - - Next_Formal (Par_Formal_Id); - Next_Formal (Subp_Formal_Id); - end loop; - - -- Check that Parent field of all the nodes have their correct - -- decoration; required because otherwise mapped nodes with - -- wrong Parent field are left unmodified in the copied tree - -- and cause reporting wrong errors at later stages. - - pragma Assert - (Check_Parents (Class_Condition (Kind, Par_Subp), Assoc_List)); - - New_Condition := + return New_Copy_Tree - (Source => Class_Condition (Kind, Par_Subp), - Map => Assoc_List); - - -- Ensure that the inherited condition has no reference to the - -- formals of the parent subprogram. - - pragma Assert (Check_Condition (New_Condition)); - - return New_Condition; + (Source => Class_Condition (Kind, Par_Subp)); end Inherit_Condition; ---------------------- @@ -4606,9 +4525,7 @@ package body Contracts is Par_Prim := Subp_Id; Par_Iface_Prims := Covered_Interface_Primitives (Par_Prim); - Cond := Inherit_Condition - (Subp => Spec_Id, - Par_Subp => Subp_Id); + Cond := Inherit_Condition (Par_Subp => Subp_Id); if Present (Class_Cond) then Merge_Conditions (Cond, Class_Cond); @@ -4652,9 +4569,7 @@ package body Contracts is then Seen (Index) := Subp_Id; - Cond := Inherit_Condition - (Subp => Spec_Id, - Par_Subp => Subp_Id); + Cond := Inherit_Condition (Par_Subp => Subp_Id); Check_Class_Condition (Cond => Cond, diff --git a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst index f051810..86d2a81 100644 --- a/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst +++ b/gcc/ada/doc/gnat_rm/implementation_defined_attributes.rst @@ -1629,9 +1629,9 @@ Attribute Valid_Value .. index:: Valid_Value The ``'Valid_Value`` attribute is defined for enumeration types other than -those in package Standard. This attribute is a function that takes -a String, and returns Boolean. ``T'Valid_Value (S)`` returns True -if and only if ``T'Value (S)`` would not raise Constraint_Error. +those in package Standard or types derived from those types. This attribute is +a function that takes a String, and returns Boolean. ``T'Valid_Value (S)`` +returns True if and only if ``T'Value (S)`` would not raise Constraint_Error. Attribute Valid_Scalars ======================= diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index f154e7f..7c05e53 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1623,7 +1623,7 @@ package Einfo is -- Has_Dynamic_Predicate_Aspect -- Defined in all types and subtypes. Set if a Dynamic_Predicate aspect --- was explicitly applied to the type. Generally we treat predicates as +-- was applied to the type or subtype. Generally we treat predicates as -- static if possible, regardless of whether they are specified using -- Predicate, Static_Predicate, or Dynamic_Predicate. And if a predicate -- can be treated as static (i.e. its expression is predicate-static), diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 7cb26ce..b6c1605 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -4956,6 +4956,14 @@ package body Exp_Aggr is -- type using the computable sizes of the aggregate and its sub- -- aggregates. + function Build_Two_Pass_Aggr_Code + (Lhs : Node_Id; + Aggr_Typ : out Entity_Id) return List_Id; + -- The aggregate consists only of iterated associations and Lhs is an + -- expression containing the location of the anonymous object, which + -- may be built in place. Returns the dynamic subtype of the aggregate + -- in Aggr_Typ and the list of statements needed to build it. + procedure Check_Bounds (Aggr_Bounds_Node, Index_Bounds_Node : Node_Id); -- Checks that the bounds of Aggr_Bounds are within the bounds defined -- by Index_Bounds. For null array aggregate (Ada 2022) check that the @@ -4983,7 +4991,7 @@ package body Exp_Aggr is -- built directly into the target of an assignment, the target must -- be free of side effects. N is the target of the assignment. - procedure Two_Pass_Aggregate_Expansion (N : Node_Id); + procedure Two_Pass_Aggregate_Expansion; -- If the aggregate consists only of iterated associations then the -- aggregate is constructed in two steps: -- a) Build an expression to compute the number of elements @@ -5053,6 +5061,221 @@ package body Exp_Aggr is Freeze_Itype (Agg_Type, N); end Build_Constrained_Type; + ------------------------------ + -- Build_Two_Pass_Aggr_Code -- + ------------------------------ + + function Build_Two_Pass_Aggr_Code + (Lhs : Node_Id; + Aggr_Typ : out Entity_Id) return List_Id + is + Index_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); + Index_Type : constant Entity_Id := Etype (First_Index (Typ)); + Index_Base : constant Entity_Id := Base_Type (Index_Type); + Size_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); + Size_Type : constant Entity_Id := + Integer_Type_For + (Esize (Index_Base), Is_Unsigned_Type (Index_Base)); + + Assoc : Node_Id; + Incr : Node_Id; + Iter : Node_Id; + New_Comp : Node_Id; + One_Loop : Node_Id; + Iter_Id : Entity_Id; + + Aggr_Code : List_Id; + Size_Expr_Code : List_Id; + + begin + Size_Expr_Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Size_Id, + Object_Definition => New_Occurrence_Of (Size_Type, Loc), + Expression => Make_Integer_Literal (Loc, 0))); + + -- First pass: execute the iterators to count the number of elements + -- that will be generated. + + Assoc := First (Component_Associations (N)); + while Present (Assoc) loop + Iter := Iterator_Specification (Assoc); + Iter_Id := Defining_Identifier (Iter); + Incr := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Size_Id, Loc), + Expression => + Make_Op_Add (Loc, + Left_Opnd => New_Occurrence_Of (Size_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1))); + + -- Avoid using the same iterator definition in both loops by + -- creating a new iterator for each loop and mapping it over the + -- original iterator references. + + One_Loop := + Make_Implicit_Loop_Statement (N, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Iterator_Specification => + New_Copy_Tree (Iter, + Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))), + Statements => New_List (Incr)); + + Append (One_Loop, Size_Expr_Code); + Next (Assoc); + end loop; + + Insert_Actions (N, Size_Expr_Code); + + -- Build a constrained subtype with the bounds deduced from + -- the size computed above and declare the aggregate object. + -- The index type is some discrete type, so the bounds of the + -- constrained subtype are computed as T'Val (integer bounds). + + declare + -- Pos_Lo := Index_Type'Pos (Index_Type'First) + + Pos_Lo : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Pos, + Expressions => New_List ( + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_First))); + + -- Corresponding index value, i.e. Index_Type'First + + Aggr_Lo : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_First); + + -- Pos_Hi := Pos_Lo + Size - 1 + + Pos_Hi : constant Node_Id := + Make_Op_Add (Loc, + Left_Opnd => Pos_Lo, + Right_Opnd => + Make_Op_Subtract (Loc, + Left_Opnd => New_Occurrence_Of (Size_Id, Loc), + Right_Opnd => Make_Integer_Literal (Loc, 1))); + + -- Corresponding index value + + Aggr_Hi : constant Node_Id := + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Val, + Expressions => New_List (Pos_Hi)); + + begin + Aggr_Typ := Make_Temporary (Loc, 'T'); + + Insert_Action (N, + Make_Subtype_Declaration (Loc, + Defining_Identifier => Aggr_Typ, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Base_Type (Typ), Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint + (Loc, + Constraints => + New_List (Make_Range (Loc, Aggr_Lo, Aggr_Hi)))))); + end; + + -- Second pass: use the iterators to generate the elements of the + -- aggregate. We assume that the second evaluation of each iterator + -- generates the same number of elements as the first pass, and thus + -- consider that the execution is erroneous (even if the RM does not + -- state this explicitly) if the number of elements generated differs + -- between first and second pass. + + Assoc := First (Component_Associations (N)); + + -- Initialize insertion position to first array component + + Aggr_Code := New_List ( + Make_Object_Declaration (Loc, + Defining_Identifier => Index_Id, + Object_Definition => + New_Occurrence_Of (Index_Type, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Copy_Tree (Lhs), + Attribute_Name => Name_First))); + + while Present (Assoc) loop + Iter := Iterator_Specification (Assoc); + Iter_Id := Defining_Identifier (Iter); + New_Comp := + Make_OK_Assignment_Statement (Loc, + Name => + Make_Indexed_Component (Loc, + Prefix => New_Copy_Tree (Lhs), + Expressions => + New_List (New_Occurrence_Of (Index_Id, Loc))), + Expression => Copy_Separate_Tree (Expression (Assoc))); + + -- Arrange for the component to be adjusted if need be (the call + -- will be generated by Make_Tag_Ctrl_Assignment). + + if Needs_Finalization (Ctyp) + and then not Is_Inherently_Limited_Type (Ctyp) + then + Set_No_Finalize_Actions (New_Comp); + else + Set_No_Ctrl_Actions (New_Comp); + end if; + + -- Advance index position for insertion + + Incr := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Index_Id, Loc), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Succ, + Expressions => + New_List (New_Occurrence_Of (Index_Id, Loc)))); + + -- Add guard to skip last increment when upper bound is reached + + Incr := + Make_If_Statement (Loc, + Condition => + Make_Op_Ne (Loc, + Left_Opnd => New_Occurrence_Of (Index_Id, Loc), + Right_Opnd => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Index_Type, Loc), + Attribute_Name => Name_Last)), + Then_Statements => New_List (Incr)); + + -- Avoid using the same iterator definition in both loops by + -- creating a new iterator for each loop and mapping it over + -- the original iterator references. + + One_Loop := + Make_Implicit_Loop_Statement (N, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Iterator_Specification => + New_Copy_Tree (Iter, + Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))), + Statements => New_List (New_Comp, Incr)); + + Append (One_Loop, Aggr_Code); + Next (Assoc); + end loop; + + return Aggr_Code; + end Build_Two_Pass_Aggr_Code; + ------------------ -- Check_Bounds -- ------------------ @@ -5596,214 +5819,98 @@ package body Exp_Aggr is -- Two_Pass_Aggregate_Expansion -- ---------------------------------- - procedure Two_Pass_Aggregate_Expansion (N : Node_Id) is - Loc : constant Source_Ptr := Sloc (N); - Comp_Type : constant Entity_Id := Etype (N); - Index_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); - Index_Type : constant Entity_Id := Etype (First_Index (Etype (N))); - Index_Base : constant Entity_Id := Base_Type (Index_Type); - Size_Id : constant Entity_Id := Make_Temporary (Loc, 'I', N); - Size_Type : constant Entity_Id := - Integer_Type_For - (Esize (Index_Base), Is_Unsigned_Type (Index_Base)); - TmpE : constant Entity_Id := Make_Temporary (Loc, 'A', N); - - Assoc : Node_Id := First (Component_Associations (N)); - Incr : Node_Id; - Iter : Node_Id; - New_Comp : Node_Id; - One_Loop : Node_Id; - Iter_Id : Entity_Id; - - Size_Expr_Code : List_Id; - Insertion_Code : List_Id := New_List; + procedure Two_Pass_Aggregate_Expansion is + Aggr_Code : List_Id; + Aggr_Typ : Entity_Id; + Lhs : Node_Id; + Obj_Id : Entity_Id; + Par : Node_Id; begin - Size_Expr_Code := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Size_Id, - Object_Definition => New_Occurrence_Of (Size_Type, Loc), - Expression => Make_Integer_Literal (Loc, 0))); - - -- First pass: execute the iterators to count the number of elements - -- that will be generated. - - while Present (Assoc) loop - Iter := Iterator_Specification (Assoc); - Iter_Id := Defining_Identifier (Iter); - Incr := Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Size_Id, Loc), - Expression => - Make_Op_Add (Loc, - Left_Opnd => New_Occurrence_Of (Size_Id, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 1))); - - -- Avoid using the same iterator definition in both loops by - -- creating a new iterator for each loop and mapping it over the - -- original iterator references. - - One_Loop := Make_Implicit_Loop_Statement (N, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Iterator_Specification => - New_Copy_Tree (Iter, - Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))), - Statements => New_List (Incr)); - - Append (One_Loop, Size_Expr_Code); - Next (Assoc); + Par := Parent (N); + while Nkind (Par) = N_Qualified_Expression loop + Par := Parent (Par); end loop; - Insert_Actions (N, Size_Expr_Code); - - -- Build a constrained subtype with the bounds deduced from - -- the size computed above and declare the aggregate object. - -- The index type is some discrete type, so the bounds of the - -- constrained subtype are computed as T'Val (integer bounds). - - declare - -- Pos_Lo := Index_Type'Pos (Index_Type'First) - - Pos_Lo : constant Node_Id := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_Pos, - Expressions => New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_First))); - - -- Corresponding index value, i.e. Index_Type'First - - Aggr_Lo : constant Node_Id := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_First); - - -- Pos_Hi := Pos_Lo + Size - 1 - - Pos_Hi : constant Node_Id := - Make_Op_Add (Loc, - Left_Opnd => Pos_Lo, - Right_Opnd => - Make_Op_Subtract (Loc, - Left_Opnd => New_Occurrence_Of (Size_Id, Loc), - Right_Opnd => Make_Integer_Literal (Loc, 1))); - - -- Corresponding index value - - Aggr_Hi : constant Node_Id := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_Val, - Expressions => New_List (Pos_Hi)); + -- If the aggregate is the initialization expression of an object + -- declaration, we always build the aggregate in place, although + -- this is required only for immutably limited types and types + -- that need finalization, see RM 7.6(17.2/3-17.3/3). - SubE : constant Entity_Id := Make_Temporary (Loc, 'T'); - SubD : constant Node_Id := - Make_Subtype_Declaration (Loc, - Defining_Identifier => SubE, - Subtype_Indication => - Make_Subtype_Indication (Loc, - Subtype_Mark => - New_Occurrence_Of (Etype (Comp_Type), Loc), - Constraint => - Make_Index_Or_Discriminant_Constraint - (Loc, - Constraints => - New_List (Make_Range (Loc, Aggr_Lo, Aggr_Hi))))); - - -- Create a temporary array of the above subtype which - -- will be used to capture the aggregate assignments. - - TmpD : constant Node_Id := - Make_Object_Declaration (Loc, - Defining_Identifier => TmpE, - Object_Definition => New_Occurrence_Of (SubE, Loc)); - - begin - Insert_Actions (N, New_List (SubD, TmpD)); - end; - - -- Second pass: use the iterators to generate the elements of the - -- aggregate. Insertion index starts at Index_Type'First. We - -- assume that the second evaluation of each iterator generates - -- the same number of elements as the first pass, and consider - -- that the execution is erroneous (even if the RM does not state - -- this explicitly) if the number of elements generated differs - -- between first and second pass. - - Assoc := First (Component_Associations (N)); + if Nkind (Par) = N_Object_Declaration then + Obj_Id := Defining_Identifier (Par); + Lhs := New_Occurrence_Of (Obj_Id, Loc); + Set_Assignment_OK (Lhs); + Aggr_Code := Build_Two_Pass_Aggr_Code (Lhs, Aggr_Typ); - -- Initialize insertion position to first array component. + -- Save the last assignment statement associated with the + -- aggregate when building a controlled object. This last + -- assignment is used by the finalization machinery when + -- marking an object as successfully initialized. - Insertion_Code := New_List ( - Make_Object_Declaration (Loc, - Defining_Identifier => Index_Id, - Object_Definition => - New_Occurrence_Of (Index_Type, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_First))); + if Needs_Finalization (Typ) then + Mutate_Ekind (Obj_Id, E_Variable); + Set_Last_Aggregate_Assignment (Obj_Id, Last (Aggr_Code)); + end if; - while Present (Assoc) loop - Iter := Iterator_Specification (Assoc); - Iter_Id := Defining_Identifier (Iter); - New_Comp := Make_Assignment_Statement (Loc, - Name => - Make_Indexed_Component (Loc, - Prefix => New_Occurrence_Of (TmpE, Loc), - Expressions => - New_List (New_Occurrence_Of (Index_Id, Loc))), - Expression => Copy_Separate_Tree (Expression (Assoc))); + -- If a transient scope has been created around the declaration, + -- we need to attach the code to it so that finalization actions + -- of the declaration will be inserted after it; otherwise, we + -- directly insert it after the declaration. In both cases, the + -- code will be analyzed after the declaration is processed, i.e. + -- once the actual subtype of the object is established. - -- Advance index position for insertion. + if Scope_Is_Transient and then Par = Node_To_Be_Wrapped then + Store_After_Actions_In_Scope_Without_Analysis (Aggr_Code); + else + Insert_List_After (Par, Aggr_Code); + end if; - Incr := Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Index_Id, Loc), - Expression => - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_Succ, - Expressions => - New_List (New_Occurrence_Of (Index_Id, Loc)))); + Set_Etype (N, Aggr_Typ); + Set_No_Initialization (Par); - -- Add guard to skip last increment when upper bound is reached. + -- Likewise if it is the qualified expression of an allocator but, + -- in this case, we wait until after Expand_Allocator_Expression + -- rewrites the allocator as the initialization expression of an + -- object declaration, so that we have the left-hand side. - Incr := Make_If_Statement (Loc, - Condition => - Make_Op_Ne (Loc, - Left_Opnd => New_Occurrence_Of (Index_Id, Loc), - Right_Opnd => - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Index_Type, Loc), - Attribute_Name => Name_Last)), - Then_Statements => New_List (Incr)); + elsif Nkind (Par) = N_Allocator then + if Nkind (Parent (Par)) = N_Object_Declaration + and then + not Comes_From_Source (Defining_Identifier (Parent (Par))) + then + Obj_Id := Defining_Identifier (Parent (Par)); + Lhs := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (Obj_Id, Loc)); + Set_Assignment_OK (Lhs); + Aggr_Code := Build_Two_Pass_Aggr_Code (Lhs, Aggr_Typ); - -- Avoid using the same iterator definition in both loops by - -- creating a new iterator for each loop and mapping it over the - -- original iterator references. + Insert_Actions_After (Parent (Par), Aggr_Code); - One_Loop := Make_Implicit_Loop_Statement (N, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Iterator_Specification => - New_Copy_Tree (Iter, - Map => New_Elmt_List (Iter_Id, New_Copy (Iter_Id)))), - Statements => New_List (New_Comp, Incr)); + Set_Expression (Par, New_Occurrence_Of (Aggr_Typ, Loc)); + Set_No_Initialization (Par); + end if; - Append (One_Loop, Insertion_Code); - Next (Assoc); - end loop; + -- Otherwise we create a temporary for the anonymous object and + -- replace the aggregate with the temporary. - Insert_Actions (N, Insertion_Code); + else + Obj_Id := Make_Temporary (Loc, 'A', N); + Lhs := New_Occurrence_Of (Obj_Id, Loc); + Set_Assignment_OK (Lhs); - -- Depending on context this may not work for build-in-place - -- arrays ??? + Aggr_Code := Build_Two_Pass_Aggr_Code (Lhs, Aggr_Typ); + Prepend_To (Aggr_Code, + Make_Object_Declaration (Loc, + Defining_Identifier => Obj_Id, + Object_Definition => New_Occurrence_Of (Aggr_Typ, Loc))); - Rewrite (N, New_Occurrence_Of (TmpE, Loc)); + Insert_Actions (N, Aggr_Code); + Rewrite (N, Lhs); + Analyze_And_Resolve (N, Aggr_Typ); + end if; end Two_Pass_Aggregate_Expansion; -- Local variables @@ -5829,7 +5936,7 @@ package body Exp_Aggr is -- Aggregates that require a two-pass expansion are handled separately elsif Is_Two_Pass_Aggregate (N) then - Two_Pass_Aggregate_Expansion (N); + Two_Pass_Aggregate_Expansion; return; -- Do not attempt expansion if error already detected. We may reach this @@ -6002,12 +6109,11 @@ package body Exp_Aggr is -- static type imposed by the context. declare - Itype : constant Entity_Id := Etype (N); Index : Node_Id; Needs_Type : Boolean := False; begin - Index := First_Index (Itype); + Index := First_Index (Typ); while Present (Index) loop if not Is_OK_Static_Subtype (Etype (Index)) then Needs_Type := True; @@ -6019,7 +6125,7 @@ package body Exp_Aggr is if Needs_Type then Build_Constrained_Type (Positional => True); - Rewrite (N, Unchecked_Convert_To (Itype, N)); + Rewrite (N, Unchecked_Convert_To (Typ, N)); Analyze (N); end if; end; @@ -6147,7 +6253,7 @@ package body Exp_Aggr is then Tmp := Name (Parent_Node); - if Etype (Tmp) /= Etype (N) then + if Etype (Tmp) /= Typ then Apply_Length_Check (N, Etype (Tmp)); if Nkind (N) = N_Raise_Constraint_Error then @@ -6904,7 +7010,7 @@ package body Exp_Aggr is begin return UI_To_Int ((if Nkind (Expr) = N_Integer_Literal then Intval (Expr) - else Enumeration_Pos (Expr))); + else Enumeration_Pos (Entity (Expr)))); end To_Int; -- Local variables @@ -7362,7 +7468,7 @@ package body Exp_Aggr is -- Likewise if the aggregate is the qualified expression of an allocator -- but, in this case, we wait until after Expand_Allocator_Expression -- rewrites the allocator as the initialization expression of an object - -- declaration to have the left hand side. + -- declaration, so that we have the left-hand side. elsif Nkind (Par) = N_Allocator then if Nkind (Parent (Par)) = N_Object_Declaration @@ -7390,10 +7496,19 @@ package body Exp_Aggr is Set_Assignment_OK (Lhs); Aggr_Code := Build_Container_Aggr_Code (N, Typ, Lhs, Init); + + -- Use the unconstrained base subtype of the subtype provided by + -- the context for declaring the temporary object (which may come + -- from a constrained assignment target), to ensure that the + -- aggregate can be successfully expanded and assigned to the + -- temporary without exceeding its capacity. (Later assignment + -- of the temporary to a target object may result in failing + -- a discriminant check.) + Prepend_To (Aggr_Code, Make_Object_Declaration (Loc, Defining_Identifier => Obj_Id, - Object_Definition => New_Occurrence_Of (Typ, Loc), + Object_Definition => New_Occurrence_Of (Base_Type (Typ), Loc), Expression => Init)); Insert_Actions (N, Aggr_Code); @@ -7971,7 +8086,8 @@ package body Exp_Aggr is Make_Selected_Component (Loc, Prefix => Unchecked_Convert_To (Typ, - Duplicate_Subexpr (Parent_Expr, True)), + Duplicate_Subexpr + (Parent_Expr, Name_Req => True)), Selector_Name => New_Occurrence_Of (Comp, Loc)); Append_To (Comps, diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index b896228..18179d3 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -88,8 +88,10 @@ package body Exp_Attr is function Attribute_Op_Hash (Id : Entity_Id) return Header_Num is (Header_Num (Id mod Map_Size)); - -- Cache used to avoid building duplicate subprograms for a single - -- type/streaming-attribute pair. + -- Caches used to avoid building duplicate subprograms for a single + -- type/attribute pair (where the attribute is either Put_Image or + -- one of the four streaming attributes). The type used as a key in + -- in accessing these maps should not be the entity of a subtype. package Read_Map is new GNAT.HTable.Simple_HTable (Header_Num => Header_Num, @@ -282,8 +284,8 @@ package body Exp_Attr is (In_Same_Extended_Unit (Subp_Unit, Attr_Ref_Unit) -- If subp declared in unit body, then we don't want to refer -- to it from within unit spec so return False in that case. - and then not (Body_Required (Attr_Ref_Unit) - and not Body_Required (Subp_Unit))); + and then not (not Is_Body (Unit (Attr_Ref_Unit)) + and Is_Body (Unit (Subp_Unit)))); -- Returns True if it is ok to refer to a cached subprogram declared in -- Subp_Unit from the point of an attribute reference occurring in -- Attr_Ref_Unit. Both arguments are usually N_Compilation_Nodes, @@ -4669,7 +4671,7 @@ package body Exp_Attr is end if; if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Input_Map.Set (P_Type, Fname); + Cached_Attribute_Ops.Input_Map.Set (U_Type, Fname); end if; end Input; @@ -5750,7 +5752,7 @@ package body Exp_Attr is Rewrite_Attribute_Proc_Call (Pname); if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Output_Map.Set (P_Type, Pname); + Cached_Attribute_Ops.Output_Map.Set (U_Type, Pname); end if; end Output; @@ -6669,7 +6671,7 @@ package body Exp_Attr is Rewrite_Attribute_Proc_Call (Pname); if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Read_Map.Set (P_Type, Pname); + Cached_Attribute_Ops.Read_Map.Set (U_Type, Pname); end if; end Read; @@ -7870,9 +7872,8 @@ package body Exp_Attr is else declare Uns : constant Boolean := - Is_Unsigned_Type (Ptyp) - or else (Is_Private_Type (Ptyp) - and then Is_Unsigned_Type (PBtyp)); + Is_Unsigned_Type (Validated_View (Ptyp)); + Size : Uint; P : Node_Id := Pref; @@ -8349,7 +8350,7 @@ package body Exp_Attr is Rewrite_Attribute_Proc_Call (Pname); if not Is_Tagged_Type (P_Type) then - Cached_Attribute_Ops.Write_Map.Set (P_Type, Pname); + Cached_Attribute_Ops.Write_Map.Set (U_Type, Pname); end if; end Write; @@ -8600,10 +8601,10 @@ package body Exp_Attr is Rewrite (N, Make_Op_Multiply (Loc, Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr (Pref, True), + Prefix => Duplicate_Subexpr (Pref, Name_Req => True), Attribute_Name => Name_Length), Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr (Pref, True), + Prefix => Duplicate_Subexpr (Pref, Name_Req => True), Attribute_Name => Name_Component_Size))); Analyze_And_Resolve (N, Typ); end if; @@ -8951,15 +8952,22 @@ package body Exp_Attr is return Empty; end if; - if Nam = TSS_Stream_Read then - Ent := Cached_Attribute_Ops.Read_Map.Get (Typ); - elsif Nam = TSS_Stream_Write then - Ent := Cached_Attribute_Ops.Write_Map.Get (Typ); - elsif Nam = TSS_Stream_Input then - Ent := Cached_Attribute_Ops.Input_Map.Get (Typ); - elsif Nam = TSS_Stream_Output then - Ent := Cached_Attribute_Ops.Output_Map.Get (Typ); - end if; + declare + function U_Base return Entity_Id is + (Underlying_Type (Base_Type (Typ))); + -- Return the right type node for use in a C_A_O map lookup. + -- In particular, we do not want the entity for a subtype. + begin + if Nam = TSS_Stream_Read then + Ent := Cached_Attribute_Ops.Read_Map.Get (U_Base); + elsif Nam = TSS_Stream_Write then + Ent := Cached_Attribute_Ops.Write_Map.Get (U_Base); + elsif Nam = TSS_Stream_Input then + Ent := Cached_Attribute_Ops.Input_Map.Get (U_Base); + elsif Nam = TSS_Stream_Output then + Ent := Cached_Attribute_Ops.Output_Map.Get (U_Base); + end if; + end; Cached_Attribute_Ops.Validate_Cached_Candidate (Subp => Ent, Attr_Ref => Attr_Ref); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index bc46fd3..fa87149 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -5423,18 +5423,12 @@ package body Exp_Ch3 is -- with an initial value, its Init_Proc will never be called. The -- initial value itself may have been expanded into assignments, -- in which case the declaration has the No_Initialization flag. - -- The exception is when the initial value is a 2-pass aggregate, - -- because the special expansion used for it creates a temporary - -- that needs a fully-fledged initialization. if Is_Itype (Base) and then Nkind (Associated_Node_For_Itype (Base)) = N_Object_Declaration and then - ((Present (Expression (Associated_Node_For_Itype (Base))) - and then not - Is_Two_Pass_Aggregate - (Expression (Associated_Node_For_Itype (Base)))) + (Present (Expression (Associated_Node_For_Itype (Base))) or else No_Initialization (Associated_Node_For_Itype (Base))) then null; @@ -8293,12 +8287,15 @@ package body Exp_Ch3 is -- where the object has been initialized by a call to a function -- returning on the primary stack (see Expand_Ctrl_Function_Call) -- since no copy occurred, given that the type is by-reference. + -- Likewise if it is initialized by a 2-pass aggregate, since the + -- actual initialization will only occur during the second pass. -- Similarly, no adjustment is needed if we are going to rewrite -- the object declaration into a renaming declaration. if Needs_Finalization (Typ) and then not Is_Inherently_Limited_Type (Typ) and then Nkind (Expr_Q) /= N_Function_Call + and then not Is_Two_Pass_Aggregate (Expr_Q) and then not Rewrite_As_Renaming then Adj_Call := diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 82978c7..0cf605c 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -193,12 +193,12 @@ package body Exp_Ch4 is procedure Insert_Conditional_Object_Declaration (Obj_Id : Entity_Id; + Typ : Entity_Id; Expr : Node_Id; - Decl : Node_Id); - -- Expr is the dependent expression of a conditional expression and Decl - -- is the declaration of an object whose initialization expression is the - -- conditional expression. Insert in the actions of Expr the declaration - -- of Obj_Id modeled on Decl and with Expr as initialization expression. + Const : Boolean); + -- Expr is the dependent expression of a conditional expression. Insert in + -- the actions of Expr the declaration of Obj_Id with type Typ and Expr as + -- initialization expression. Const is True when Obj_Id is a constant. procedure Insert_Dereference_Action (N : Node_Id); -- N is an expression whose type is an access. When the type of the @@ -769,7 +769,6 @@ package body Exp_Ch4 is -- Local variables Aggr_In_Place : Boolean; - Container_Aggr : Boolean; Delayed_Cond_Expr : Boolean; TagT : Entity_Id := Empty; @@ -865,13 +864,15 @@ package body Exp_Ch4 is Aggr_In_Place := Is_Delayed_Aggregate (Exp); Delayed_Cond_Expr := Is_Delayed_Conditional_Expression (Exp); - Container_Aggr := Nkind (Exp) = N_Aggregate - and then Has_Aspect (T, Aspect_Aggregate); - -- An allocator with a container aggregate as qualified expression must - -- be rewritten into the form expected by Expand_Container_Aggregate. + -- An allocator with a container aggregate, resp. a 2-pass aggregate, + -- as qualified expression must be rewritten into the form expected by + -- Expand_Container_Aggregate, resp. Two_Pass_Aggregate_Expansion. - if Container_Aggr then + if Nkind (Exp) = N_Aggregate + and then (Has_Aspect (T, Aspect_Aggregate) + or else Is_Two_Pass_Aggregate (Exp)) + then Temp := Make_Temporary (Loc, 'P', N); Set_Analyzed (Exp, False); Insert_Action (N, @@ -5303,7 +5304,7 @@ package body Exp_Ch4 is -- 'Unrestricted_Access. -- Generate: - -- type Ptr_Typ is not null access all [constant] Typ; + -- type Target_Typ is not null access all [constant] Typ; else Target_Typ := Make_Temporary (Loc, 'P'); @@ -5401,20 +5402,16 @@ package body Exp_Ch4 is elsif Optimize_Object_Decl then Obj := Make_Temporary (Loc, 'C', Alt_Expr); - Insert_Conditional_Object_Declaration (Obj, Alt_Expr, Par); - - Alt_Expr := - Make_Attribute_Reference (Alt_Loc, - Prefix => New_Occurrence_Of (Obj, Alt_Loc), - Attribute_Name => Name_Unrestricted_Access); - - LHS := New_Occurrence_Of (Target, Loc); - Set_Assignment_OK (LHS); + Insert_Conditional_Object_Declaration + (Obj, Typ, Alt_Expr, Const => Constant_Present (Par)); Stmts := New_List ( Make_Assignment_Statement (Alt_Loc, - Name => LHS, - Expression => Alt_Expr)); + Name => New_Occurrence_Of (Target, Loc), + Expression => + Make_Attribute_Reference (Alt_Loc, + Prefix => New_Occurrence_Of (Obj, Alt_Loc), + Attribute_Name => Name_Unrestricted_Access))); -- Take the unrestricted access of the expression value for non- -- scalar types. This approach avoids big copies and covers the @@ -6012,8 +6009,10 @@ package body Exp_Ch4 is Target : constant Entity_Id := Make_Temporary (Loc, 'C', N); begin - Insert_Conditional_Object_Declaration (Then_Obj, Thenx, Par); - Insert_Conditional_Object_Declaration (Else_Obj, Elsex, Par); + Insert_Conditional_Object_Declaration + (Then_Obj, Typ, Thenx, Const => Constant_Present (Par)); + Insert_Conditional_Object_Declaration + (Else_Obj, Typ, Elsex, Const => Constant_Present (Par)); -- Generate: -- type Ptr_Typ is not null access all [constant] Typ; @@ -13284,17 +13283,20 @@ package body Exp_Ch4 is procedure Insert_Conditional_Object_Declaration (Obj_Id : Entity_Id; + Typ : Entity_Id; Expr : Node_Id; - Decl : Node_Id) + Const : Boolean) is Loc : constant Source_Ptr := Sloc (Expr); Obj_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Obj_Id, - Aliased_Present => Aliased_Present (Decl), - Constant_Present => Constant_Present (Decl), - Object_Definition => New_Copy_Tree (Object_Definition (Decl)), + Aliased_Present => True, + Constant_Present => Const, + Object_Definition => New_Occurrence_Of (Typ, Loc), Expression => Relocate_Node (Expr)); + -- We make the object unconditionally aliased to avoid dangling bound + -- issues when its nominal subtype is an unconstrained array type. Master_Node_Decl : Node_Id; Master_Node_Id : Entity_Id; @@ -13309,6 +13311,21 @@ package body Exp_Ch4 is Insert_Action (Expr, Obj_Decl); + -- The object can never be local to an elaboration routine at library + -- level since we will take 'Unrestricted_Access of it. Beware that + -- Is_Library_Level_Entity always returns False when called from within + -- a transient scope, but the associated block will not be materialized + -- when the transient scope is finally closed in the case of an object + -- declaration (see Exp.Ch7.Wrap_Transient_Declaration). + + if Scope (Obj_Id) = Current_Scope and then Scope_Is_Transient then + Set_Is_Statically_Allocated + (Obj_Id, Is_Library_Level_Entity (Scope (Obj_Id))); + else + Set_Is_Statically_Allocated + (Obj_Id, Is_Library_Level_Entity (Obj_Id)); + end if; + -- If the object needs finalization, we need to insert its Master_Node -- manually because 1) the machinery in Exp_Ch7 will not pick it since -- it will be declared in the arm of a conditional statement and 2) we @@ -15035,10 +15052,11 @@ package body Exp_Ch4 is -- Handle entities from the limited view - Orig_Right_Type : constant Entity_Id := Available_View (Etype (Right)); + Orig_Right_Type : constant Entity_Id := + Base_Type (Available_View (Etype (Right))); Full_R_Typ : Entity_Id; - Left_Type : Entity_Id := Available_View (Etype (Left)); + Left_Type : Entity_Id := Base_Type (Available_View (Etype (Left))); Right_Type : Entity_Id := Orig_Right_Type; Obj_Tag : Node_Id; diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 06616ea..3d8a542 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -1039,7 +1039,8 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr_Move_Checks (Larray, True), + Duplicate_Subexpr_Move_Checks + (Larray, Name_Req => True), Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => @@ -1054,7 +1055,8 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr_Move_Checks (Rarray, True), + Duplicate_Subexpr_Move_Checks + (Rarray, Name_Req => True), Expressions => New_List ( Make_Attribute_Reference (Loc, Prefix => @@ -1396,7 +1398,7 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr (Larray, True), + Duplicate_Subexpr (Larray, Name_Req => True), Expressions => New_List (New_Copy_Tree (Left_Lo))), Attribute_Name => Name_Address); @@ -1405,7 +1407,7 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr (Larray, True), + Duplicate_Subexpr (Larray, Name_Req => True), Expressions => New_List (New_Copy_Tree (Left_Lo))), Attribute_Name => Name_Bit); @@ -1414,7 +1416,7 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr (Rarray, True), + Duplicate_Subexpr (Rarray, Name_Req => True), Expressions => New_List (New_Copy_Tree (Right_Lo))), Attribute_Name => Name_Address); @@ -1423,7 +1425,7 @@ package body Exp_Ch5 is Prefix => Make_Indexed_Component (Loc, Prefix => - Duplicate_Subexpr (Rarray, True), + Duplicate_Subexpr (Rarray, Name_Req => True), Expressions => New_List (New_Copy_Tree (Right_Lo))), Attribute_Name => Name_Bit); @@ -1439,11 +1441,11 @@ package body Exp_Ch5 is Make_Op_Multiply (Loc, Make_Attribute_Reference (Loc, Prefix => - Duplicate_Subexpr (Name (N), True), + Duplicate_Subexpr (Name (N), Name_Req => True), Attribute_Name => Name_Length), Make_Attribute_Reference (Loc, Prefix => - Duplicate_Subexpr (Name (N), True), + Duplicate_Subexpr (Name (N), Name_Req => True), Attribute_Name => Name_Component_Size)); begin @@ -1527,11 +1529,11 @@ package body Exp_Ch5 is Make_Op_Multiply (Loc, Make_Attribute_Reference (Loc, Prefix => - Duplicate_Subexpr (Name (N), True), + Duplicate_Subexpr (Name (N), Name_Req => True), Attribute_Name => Name_Length), Make_Attribute_Reference (Loc, Prefix => - Duplicate_Subexpr (Larray, True), + Duplicate_Subexpr (Larray, Name_Req => True), Attribute_Name => Name_Component_Size)); L_Arg, R_Arg, Call : Node_Id; @@ -1582,7 +1584,7 @@ package body Exp_Ch5 is end if; return Make_Assignment_Statement (Loc, - Name => Duplicate_Subexpr (Larray, True), + Name => Duplicate_Subexpr (Larray, Name_Req => True), Expression => Unchecked_Convert_To (L_Typ, Call)); end Expand_Assign_Array_Bitfield_Fast; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 7e46454..f85d977 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -2470,11 +2470,6 @@ package body Exp_Ch6 is -- (and ensure that we have an activation chain defined for tasks -- and a Master variable). - -- Currently we limit such functions to those with inherently - -- limited result subtypes, but eventually we plan to expand the - -- functions that are treated as build-in-place to include other - -- composite result types. - -- But do not do it here for intrinsic subprograms since this will -- be done properly after the subprogram is expanded. @@ -8562,12 +8557,10 @@ package body Exp_Ch6 is procedure Make_Build_In_Place_Call_In_Anonymous_Context (Function_Call : Node_Id) is - Loc : constant Source_Ptr := Sloc (Function_Call); - Func_Call : constant Node_Id := Unqual_Conv (Function_Call); - Function_Id : Entity_Id; - Result_Subt : Entity_Id; - Return_Obj_Id : Entity_Id; - Return_Obj_Decl : Entity_Id; + Loc : constant Source_Ptr := Sloc (Function_Call); + Func_Call : constant Node_Id := Unqual_Conv (Function_Call); + Function_Id : Entity_Id; + Result_Subt : Entity_Id; begin -- If the call has already been processed to add build-in-place actuals @@ -8580,10 +8573,6 @@ package body Exp_Ch6 is return; end if; - -- Mark the call as processed as a build-in-place call - - Set_Is_Expanded_Build_In_Place_Call (Func_Call); - if Is_Entity_Name (Name (Func_Call)) then Function_Id := Entity (Name (Func_Call)); @@ -8601,8 +8590,13 @@ package body Exp_Ch6 is -- If the build-in-place function returns a controlled object, then the -- object needs to be finalized immediately after the context. Since -- this case produces a transient scope, the servicing finalizer needs - -- to name the returned object. Create a temporary which is initialized - -- with the function call: + -- to name the returned object. + + -- If the build-in-place function returns a definite subtype, then an + -- object also needs to be created and an access value designating it + -- passed as an actual. + + -- Create a temporary which is initialized with the function call: -- -- Temp_Id : Func_Type := BIP_Func_Call; -- @@ -8610,75 +8604,25 @@ package body Exp_Ch6 is -- the expander using the appropriate mechanism in Make_Build_In_Place_ -- Call_In_Object_Declaration. - if Needs_Finalization (Result_Subt) then + if Needs_Finalization (Result_Subt) + or else Caller_Known_Size (Func_Call, Result_Subt) + then declare Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'R'); - Temp_Decl : Node_Id; - - begin - -- Reset the guard on the function call since the following does - -- not perform actual call expansion. - - Set_Is_Expanded_Build_In_Place_Call (Func_Call, False); - - Temp_Decl := + Temp_Decl : constant Node_Id := Make_Object_Declaration (Loc, Defining_Identifier => Temp_Id, - Object_Definition => - New_Occurrence_Of (Result_Subt, Loc), - Expression => - New_Copy_Tree (Function_Call)); + Aliased_Present => True, + Object_Definition => New_Occurrence_Of (Result_Subt, Loc), + Expression => Relocate_Node (Function_Call)); + begin + Set_Assignment_OK (Temp_Decl); Insert_Action (Function_Call, Temp_Decl); - Rewrite (Function_Call, New_Occurrence_Of (Temp_Id, Loc)); Analyze (Function_Call); end; - -- When the result subtype is definite, an object of the subtype is - -- declared and an access value designating it is passed as an actual. - - elsif Caller_Known_Size (Func_Call, Result_Subt) then - - -- Create a temporary object to hold the function result - - Return_Obj_Id := Make_Temporary (Loc, 'R'); - Set_Etype (Return_Obj_Id, Result_Subt); - - Return_Obj_Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Return_Obj_Id, - Aliased_Present => True, - Object_Definition => New_Occurrence_Of (Result_Subt, Loc)); - - Set_No_Initialization (Return_Obj_Decl); - - Insert_Action (Func_Call, Return_Obj_Decl); - - -- When the function has a controlling result, an allocation-form - -- parameter must be passed indicating that the caller is allocating - -- the result object. This is needed because such a function can be - -- called as a dispatching operation and must be treated similarly - -- to functions with unconstrained result subtypes. - - Add_Unconstrained_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Alloc_Form => Caller_Allocation); - - Add_Collection_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id); - - Add_Task_Actuals_To_Build_In_Place_Call - (Func_Call, Function_Id, Make_Identifier (Loc, Name_uMaster)); - - -- Add an implicit actual to the function call that provides access - -- to the caller's return object. - - Add_Access_Actual_To_Build_In_Place_Call - (Func_Call, Function_Id, New_Occurrence_Of (Return_Obj_Id, Loc)); - - pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); - pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id)); - -- When the result subtype is unconstrained, the function must allocate -- the return object in the secondary stack, so appropriate implicit -- parameters are added to the call to indicate that. A transient @@ -8703,6 +8647,10 @@ package body Exp_Ch6 is Add_Access_Actual_To_Build_In_Place_Call (Func_Call, Function_Id, Empty); + -- Mark the call as processed as a build-in-place call + + Set_Is_Expanded_Build_In_Place_Call (Func_Call); + pragma Assert (Check_Number_Of_Actuals (Func_Call, Function_Id)); pragma Assert (Check_BIP_Actuals (Func_Call, Function_Id)); end if; @@ -9909,6 +9857,13 @@ package body Exp_Ch6 is return Skip; end if; + -- Skip calls placed in unexpanded initialization expressions + + when N_Object_Declaration => + if No_Initialization (Nod) then + return Skip; + end if; + -- Skip calls placed in subprogram specifications since function -- calls initializing default parameter values will be processed -- when the call to the subprogram is found (if the default actual diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 67af1d7..905094c 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -2783,16 +2783,31 @@ package body Exp_Ch7 is Master_Node_Id := Make_Defining_Identifier (Master_Node_Loc, Chars => New_External_Name (Chars (Obj_Id), Suffix => "MN")); + Master_Node_Decl := Make_Master_Node_Declaration (Master_Node_Loc, Master_Node_Id, Obj_Id); Push_Scope (Scope (Obj_Id)); + + -- Avoid generating duplicate names for master nodes + + if Ekind (Obj_Id) = E_Loop_Parameter + and then + Present (Current_Entity_In_Scope (Chars (Master_Node_Id))) + then + Set_Chars (Master_Node_Id, + New_External_Name (Chars (Obj_Id), + Suffix => "MN", + Suffix_Index => -1)); + end if; + if not Has_Strict_Ctrl_Objs or else Count = 1 then Prepend_To (Decls, Master_Node_Decl); else Insert_Before (Decl, Master_Node_Decl); end if; + Analyze (Master_Node_Decl); Pop_Scope; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index b8c6a9f..44e26d1 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1081,10 +1081,12 @@ package body Exp_Util is Make_Attribute_Reference (Loc, Prefix => (if Is_Allocate then - Duplicate_Subexpr_No_Checks (Expression (Alloc_Expr)) + Duplicate_Subexpr_No_Checks + (Expression (Alloc_Expr), New_Scope => Proc_Id) else Make_Explicit_Dereference (Loc, - Duplicate_Subexpr_No_Checks (Expr))), + Duplicate_Subexpr_No_Checks + (Expr, New_Scope => Proc_Id))), Attribute_Name => Name_Alignment))); end if; @@ -1137,7 +1139,9 @@ package body Exp_Util is if Is_RTE (Etype (Temp), RE_Tag_Ptr) then Param := Make_Explicit_Dereference (Loc, - Prefix => Duplicate_Subexpr_No_Checks (Temp)); + Prefix => + Duplicate_Subexpr_No_Checks + (Temp, New_Scope => Proc_Id)); -- In the default case, obtain the tag of the object about -- to be allocated / deallocated. Generate: @@ -1157,7 +1161,9 @@ package body Exp_Util is Param := Make_Attribute_Reference (Loc, - Prefix => Duplicate_Subexpr_No_Checks (Temp), + Prefix => + Duplicate_Subexpr_No_Checks + (Temp, New_Scope => Proc_Id), Attribute_Name => Name_Tag); end if; @@ -1517,7 +1523,118 @@ package body Exp_Util is New_E := Type_Map.Get (Entity (N)); if Present (New_E) then - Rewrite (N, New_Occurrence_Of (New_E, Sloc (N))); + declare + + Ctrl_Type : constant Entity_Id + := Find_Dispatching_Type (Par_Subp); + + function Call_To_Parent_Dispatching_Op_Must_Be_Mapped + (Call_Node : Node_Id) return Boolean; + -- If Call_Node is a call to a primitive function F of the + -- tagged type T associated with Par_Subp that either has + -- any actuals that are controlling formals of Par_Subp, + -- or else the call to F is an actual parameter of an + -- enclosing call to a primitive of T that has any actuals + -- that are controlling formals of Par_Subp (and recursively + -- up the tree of enclosing function calls), returns True; + -- otherwise returns False. Returning True implies that the + -- call to F must be mapped to a call that instead targets + -- the corresponding function F of the tagged type for which + -- Subp is a primitive function. + + -------------------------------------------------- + -- Call_To_Parent_Dispatching_Op_Must_Be_Mapped -- + -------------------------------------------------- + + function Call_To_Parent_Dispatching_Op_Must_Be_Mapped + (Call_Node : Node_Id) return Boolean + is + pragma Assert (Nkind (Call_Node) = N_Function_Call); + + Actual : Node_Id := First_Actual (Call_Node); + Actual_Type : Entity_Id; + Actual_Or_Prefix : Node_Id; + + begin + if Is_Entity_Name (Name (Call_Node)) + and then Is_Dispatching_Operation + (Entity (Name (Call_Node))) + and then + Is_Ancestor + (Ctrl_Type, + Find_Dispatching_Type + (Entity (Name (Call_Node)))) + then + while Present (Actual) loop + + -- Account for 'Old and explicit dereferences, + -- picking up the prefix object in those cases. + + if (Nkind (Actual) = N_Attribute_Reference + and then Attribute_Name (Actual) = Name_Old) + or else Nkind (Actual) = N_Explicit_Dereference + then + Actual_Or_Prefix := Prefix (Actual); + else + Actual_Or_Prefix := Actual; + end if; + + Actual_Type := Etype (Actual); + + if Is_Anonymous_Access_Type (Actual_Type) then + Actual_Type := Designated_Type (Actual_Type); + end if; + + if Nkind (Actual_Or_Prefix) + in N_Identifier + | N_Expanded_Name + | N_Operator_Symbol + + and then Is_Formal (Entity (Actual_Or_Prefix)) + + and then Covers (Ctrl_Type, Actual_Type) + then + -- At least one actual is a formal parameter of + -- Par_Subp with type Ctrl_Type. + + return True; + end if; + + Next_Actual (Actual); + end loop; + + if Nkind (Parent (Call_Node)) = N_Function_Call then + return + Call_To_Parent_Dispatching_Op_Must_Be_Mapped + (Parent (Call_Node)); + end if; + + return False; + + else + return False; + end if; + end Call_To_Parent_Dispatching_Op_Must_Be_Mapped; + + begin + -- If N's entity is in the map, then the entity is either + -- a formal of the parent subprogram that should necessarily + -- be mapped, or it's a function call's target entity that + -- that should be mapped if the call involves any actuals + -- that reference formals of the parent subprogram (or the + -- function call is part of an enclosing call that similarly + -- qualifies for mapping). Rewrite a node that references + -- any such qualified entity to a new node referencing the + -- corresponding entity associated with the derived type. + + if not Is_Subprogram (Entity (N)) + or else Nkind (Parent (N)) /= N_Function_Call + or else + Call_To_Parent_Dispatching_Op_Must_Be_Mapped (Parent (N)) + then + Rewrite (N, New_Occurrence_Of (New_E, Sloc (N))); + end if; + end; end if; -- Update type of function call node, which should be the same as @@ -5062,12 +5179,13 @@ package body Exp_Util is function Duplicate_Subexpr (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id is begin Remove_Side_Effects (Exp, Name_Req, Renaming_Req); - return New_Copy_Tree (Exp); + return New_Copy_Tree (Exp, New_Scope => New_Scope); end Duplicate_Subexpr; --------------------------------- @@ -5076,8 +5194,9 @@ package body Exp_Util is function Duplicate_Subexpr_No_Checks (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id is New_Exp : Node_Id; @@ -5087,7 +5206,7 @@ package body Exp_Util is Name_Req => Name_Req, Renaming_Req => Renaming_Req); - New_Exp := New_Copy_Tree (Exp); + New_Exp := New_Copy_Tree (Exp, New_Scope => New_Scope); Remove_Checks (New_Exp); return New_Exp; end Duplicate_Subexpr_No_Checks; @@ -5098,14 +5217,15 @@ package body Exp_Util is function Duplicate_Subexpr_Move_Checks (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id is New_Exp : Node_Id; begin Remove_Side_Effects (Exp, Name_Req, Renaming_Req); - New_Exp := New_Copy_Tree (Exp); + New_Exp := New_Copy_Tree (Exp, New_Scope => New_Scope); Remove_Checks (Exp); return New_Exp; end Duplicate_Subexpr_Move_Checks; diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 6178767..1306f5e 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -479,8 +479,9 @@ package Exp_Util is function Duplicate_Subexpr (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id; + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id; -- Given the node for a subexpression, this function makes a logical copy -- of the subexpression, and returns it. This is intended for use when the -- expansion of an expression needs to repeat part of it. For example, @@ -494,6 +495,9 @@ package Exp_Util is -- the caller is responsible for analyzing the returned copy after it is -- attached to the tree. -- + -- The New_Scope entity may be used to specify a new scope for all copied + -- entities and itypes. + -- -- The Name_Req flag is set to ensure that the result is suitable for use -- in a context requiring a name (for example, the prefix of an attribute -- reference). @@ -509,8 +513,9 @@ package Exp_Util is function Duplicate_Subexpr_No_Checks (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id; + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id; -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks is -- called on the result, so that the duplicated expression does not include -- checks. This is appropriate for use when Exp, the original expression is @@ -519,8 +524,9 @@ package Exp_Util is function Duplicate_Subexpr_Move_Checks (Exp : Node_Id; - Name_Req : Boolean := False; - Renaming_Req : Boolean := False) return Node_Id; + New_Scope : Entity_Id := Empty; + Name_Req : Boolean := False; + Renaming_Req : Boolean := False) return Node_Id; -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks is -- called on Exp after the duplication is complete, so that the original -- expression does not include checks. In this case the result returned diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 54b6202..eb751e1 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -6869,9 +6869,10 @@ package body Freeze is end if; end if; - -- Static objects require special handling + -- Statically allocated objects require special handling if (Ekind (E) = E_Constant or else Ekind (E) = E_Variable) + and then No (Renamed_Object (E)) and then Is_Statically_Allocated (E) then Freeze_Static_Object (E); @@ -10230,11 +10231,17 @@ package body Freeze is -- issue an error message saying that this object cannot be imported -- or exported. If it has an address clause it is an overlay in the -- current partition and the static requirement is not relevant. - -- Do not issue any error message when ignoring rep clauses. + -- Do not issue any error message when ignoring rep clauses or for + -- compiler-generated entities. if Ignore_Rep_Clauses then null; + elsif not Comes_From_Source (E) then + pragma + Assert (Nkind (Parent (Declaration_Node (E))) in N_Case_Statement + | N_If_Statement); + elsif Is_Imported (E) then if No (Address_Clause (E)) then Error_Msg_N diff --git a/gcc/ada/gnat_rm.texi b/gcc/ada/gnat_rm.texi index 97469d7..54830b8 100644 --- a/gcc/ada/gnat_rm.texi +++ b/gcc/ada/gnat_rm.texi @@ -12360,9 +12360,9 @@ which changes element (1,2) to 20 and (3,4) to 30. @geindex Valid_Value The @code{'Valid_Value} attribute is defined for enumeration types other than -those in package Standard. This attribute is a function that takes -a String, and returns Boolean. @code{T'Valid_Value (S)} returns True -if and only if @code{T'Value (S)} would not raise Constraint_Error. +those in package Standard or types derived from those types. This attribute is +a function that takes a String, and returns Boolean. @code{T'Valid_Value (S)} +returns True if and only if @code{T'Value (S)} would not raise Constraint_Error. @node Attribute Valid_Scalars,Attribute VADS_Size,Attribute Valid_Value,Implementation Defined Attributes @anchor{gnat_rm/implementation_defined_attributes attribute-valid-scalars}@anchor{1c5} diff --git a/gcc/ada/libgnarl/s-stusta.adb b/gcc/ada/libgnarl/s-stusta.adb index 5aca435..c9848a0 100644 --- a/gcc/ada/libgnarl/s-stusta.adb +++ b/gcc/ada/libgnarl/s-stusta.adb @@ -32,6 +32,7 @@ -- This is why this package is part of GNARL: with System.Tasking.Debug; +with System.Tasking.Stages; with System.Task_Primitives.Operations; with System.IO; @@ -103,7 +104,9 @@ package body System.Stack_Usage.Tasking is -- Calculate the task usage for a given task - Report_For_Task (Id); + if not System.Tasking.Stages.Terminated (Id) then + Report_For_Task (Id); + end if; end loop; end if; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index af08fdb..08da29a 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -7511,13 +7511,14 @@ package body Sem_Attr is Set_Etype (N, Standard_Boolean); Validate_Non_Static_Attribute_Function_Call; - if P_Type in Standard_Boolean + if Root_Type (P_Type) in Standard_Boolean | Standard_Character | Standard_Wide_Character | Standard_Wide_Wide_Character then Error_Attr_P - ("prefix of % attribute must not be a type in Standard"); + ("prefix of % attribute must not be a type originating from " & + "Standard"); end if; if Discard_Names (First_Subtype (P_Type)) then diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb index 3399a41..c81b563 100644 --- a/gcc/ada/sem_case.adb +++ b/gcc/ada/sem_case.adb @@ -3684,13 +3684,15 @@ package body Sem_Case is -- Use of nonstatic predicate is an error if not Is_Discrete_Type (E) - or else not Has_Static_Predicate (E) + or else (not Has_Static_Predicate (E) + and then + not Has_Static_Predicate_Aspect (E)) or else Has_Dynamic_Predicate_Aspect (E) or else Has_Ghost_Predicate_Aspect (E) then Bad_Predicated_Subtype_Use - ("cannot use subtype& with non-static " - & "predicate as case alternative", + ("cannot use subtype& with nonstatic " + & "predicate as choice in case alternative", Choice, E, Suggest_Static => True); -- Static predicate case. The bounds are those of diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index de5a8c8..e3d9925 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -4932,6 +4932,8 @@ package body Sem_Ch10 is if Entity (Name (Clause)) = Id or else (Nkind (Name (Clause)) = N_Expanded_Name + and then + Is_Entity_Name (Prefix (Name (Clause))) and then Entity (Prefix (Name (Clause))) = Id) then return True; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 5768e28e..02c7c36 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -9340,9 +9340,6 @@ package body Sem_Ch12 is and then Nkind (Ancestor_Type (N)) in N_Entity then declare - Root_Typ : constant Entity_Id := - Root_Type (Ancestor_Type (N)); - Typ : Entity_Id := Ancestor_Type (N); begin @@ -9351,7 +9348,7 @@ package body Sem_Ch12 is Switch_View (Typ); end if; - exit when Typ = Root_Typ; + exit when Etype (Typ) = Typ; Typ := Etype (Typ); end loop; @@ -14132,6 +14129,16 @@ package body Sem_Ch12 is T2 := Etype (I2); end if; + -- In the case of a fixed-lower-bound subtype, we want to check + -- against the index type's range rather than the range of the + -- subtype (which will be seen as unconstrained, and whose bounds + -- won't generally match those of the formal unconstrained array + -- type's corresponding index type). + + if Is_Fixed_Lower_Bound_Index_Subtype (T2) then + T2 := Etype (Scalar_Range (T2)); + end if; + if not Subtypes_Match (Find_Actual_Type (Etype (I1), A_Gen_T), T2) then diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 74eac9c..9a25ff7 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4991,7 +4991,7 @@ package body Sem_Ch3 is if Is_Array_Type (T) and then No_Initialization (N) - and then Nkind (Original_Node (E)) = N_Aggregate + and then Nkind (Unqualify (Original_Node (E))) = N_Aggregate then Act_T := Etype (E); @@ -5137,10 +5137,7 @@ package body Sem_Ch3 is elsif Is_Array_Type (T) and then No_Initialization (N) - and then (Nkind (Original_Node (E)) = N_Aggregate - or else (Nkind (Original_Node (E)) = N_Qualified_Expression - and then Nkind (Original_Node (Expression - (Original_Node (E)))) = N_Aggregate)) + and then Nkind (Unqualify (Original_Node (E))) = N_Aggregate then if not Is_Entity_Name (Object_Definition (N)) then Act_T := Etype (E); @@ -6633,8 +6630,6 @@ package body Sem_Ch3 is end; end if; - -- Constrained array case - if No (T) then -- We might be creating more than one itype with the same Related_Id, -- e.g. for an array object definition and its initial value. Give @@ -6644,6 +6639,8 @@ package body Sem_Ch3 is T := Create_Itype (E_Void, P, Related_Id, 'T', Suffix_Index => -1); end if; + -- Constrained array case + if Nkind (Def) = N_Constrained_Array_Definition then Index := First (Discrete_Subtype_Definitions (Def)); @@ -15095,7 +15092,8 @@ package body Sem_Ch3 is -- If this is a range for a fixed-lower-bound subtype, then set the -- index itype's low bound to the FLB and the index itype's upper bound -- to the high bound of the parent array type's index subtype. Also, - -- mark the itype as an FLB index subtype. + -- set the Etype of the new scalar range and mark the itype as an FLB + -- index subtype. if Nkind (S) = N_Range and then Is_FLB_Index then Set_Scalar_Range @@ -15103,6 +15101,7 @@ package body Sem_Ch3 is Make_Range (Sloc (S), Low_Bound => Low_Bound (S), High_Bound => Type_High_Bound (T))); + Set_Etype (Scalar_Range (Def_Id), Etype (Index)); Set_Is_Fixed_Lower_Bound_Index_Subtype (Def_Id); else diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 4069839..8be9647 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -308,8 +308,12 @@ package body Sem_Ch4 is (N : Node_Id; Prefix : Node_Id; Exprs : List_Id) return Boolean; - -- AI05-0139: Generalized indexing to support iterators over containers - -- ??? Need to provide a more detailed spec of what this function does + -- AI05-0139: Generalized indexing to support iterators over containers. + -- Given the N_Indexed_Component node N, with the given prefix and + -- expressions list, check if the generalized indexing is applicable; + -- if applicable then build its indexing function, link it to N through + -- attribute Generalized_Indexing, and return True; otherwise return + -- False. function Try_Indexed_Call (N : Node_Id; @@ -7642,35 +7646,14 @@ package body Sem_Ch4 is begin if not Is_Overloaded (R) then if Is_Numeric_Type (Etype (R)) then - - -- In an instance a generic actual may be a numeric type even if - -- the formal in the generic unit was not. In that case, the - -- predefined operator was not a possible interpretation in the - -- generic, and cannot be one in the instance, unless the operator - -- is an actual of an instance. - - if In_Instance - and then - not Is_Numeric_Type (Corresponding_Generic_Type (Etype (R))) - then - null; - else - Add_One_Interp (N, Op_Id, Base_Type (Etype (R))); - end if; + Add_One_Interp (N, Op_Id, Base_Type (Etype (R))); end if; else Get_First_Interp (R, Index, It); while Present (It.Typ) loop if Is_Numeric_Type (It.Typ) then - if In_Instance - and then - not Is_Numeric_Type - (Corresponding_Generic_Type (Etype (It.Typ))) - then - null; - - elsif Is_Effectively_Visible_Operator (N, Base_Type (It.Typ)) + if Is_Effectively_Visible_Operator (N, Base_Type (It.Typ)) then Add_One_Interp (N, Op_Id, Base_Type (It.Typ)); end if; @@ -8533,21 +8516,29 @@ package body Sem_Ch4 is Prefix : Node_Id; Exprs : List_Id) return Boolean is - Pref_Typ : Entity_Id := Etype (Prefix); + Heuristic : Boolean := False; + Pref_Typ : Entity_Id := Etype (Prefix); function Constant_Indexing_OK return Boolean; - -- Constant_Indexing is legal if there is no Variable_Indexing defined - -- for the type, or else node not a target of assignment, or an actual - -- for an IN OUT or OUT formal (RM 4.1.6 (11)). - - function Expr_Matches_In_Formal - (Subp : Entity_Id; - Par : Node_Id) return Boolean; - -- Find formal corresponding to given indexed component that is an - -- actual in a call. Note that the enclosing subprogram call has not - -- been analyzed yet, and the parameter list is not normalized, so - -- that if the argument is a parameter association we must match it - -- by name and not by position. + -- Determines whether the Constant_Indexing aspect has been specified + -- for the type of the prefix and can be interpreted as constant + -- indexing; that is, there is no Variable_Indexing defined for the + -- type, or else the node is not a target of an assignment, or an + -- actual for an IN OUT or OUT formal, or the name in an object + -- renaming (RM 4.1.6 (12/3..15/3)). + -- + -- Given that prefix notation calls have not yet been resolved, if the + -- type of the prefix has both aspects present (Constant_Indexing and + -- Variable_Indexing), and context analysis performed by this routine + -- identifies a potential prefix notation call (i.e., an N_Selected_ + -- Component node), this function may rely on heuristics to decide + -- between constant or variable indexing. In such cases, if the + -- decision is later found to be incorrect, Try_Container_Indexing + -- will retry using the alternative indexing aspect. + + -- When heuristics are used to compute the result of this function + -- the behavior of Try_Container_Indexing might not be strictly + -- following the rules of the RM. function Indexing_Interpretations (T : Entity_Id; @@ -8555,59 +8546,429 @@ package body Sem_Ch4 is -- Return a set of interpretations reflecting all of the functions -- associated with an indexing aspect of type T of the given kind. + function Try_Indexing_Function + (Func_Name : Node_Id; + Assoc : List_Id) return Entity_Id; + -- Build a call to the given indexing function name with the given + -- parameter associations; if there are several indexing functions + -- the call is analyzed for each of the interpretation; if there are + -- several successfull candidates, resolution is handled by result. + -- Return the Etype of the built function call. + -------------------------- -- Constant_Indexing_OK -- -------------------------- function Constant_Indexing_OK return Boolean is - Par : Node_Id; + + function Expr_Matches_In_Formal + (Subp : Entity_Id; + Subp_Call : Node_Id; + Param : Node_Id; + Skip_Controlling_Formal : Boolean := False) return Boolean; + -- Find formal corresponding to given indexed component that is an + -- actual in a call. Note that the enclosing subprogram call has not + -- been analyzed yet, and the parameter list is not normalized, so + -- that if the argument is a parameter association we must match it + -- by name and not by position. In the traversal up the tree done by + -- Constant_Indexing_OK, the previous node in the traversal (that is, + -- the actual parameter used to ascend to the subprogram call node), + -- is passed to this function in formal Param, and it is used to + -- determine wether the argument is passed by name or by position. + -- Skip_Controlling_Formal is set to True to skip the first formal + -- of Subp. + + procedure Handle_Selected_Component + (Current_Node : Node_Id; + Sel_Comp : Node_Id; + Candidate : out Entity_Id; + Is_Constant_Idx : out Boolean); + -- Current_Node is the current node climbing up the tree. Determine + -- if Sel_Comp is a candidate for a prefixed call using constant + -- indexing; if no candidate is found Candidate is returned Empty + -- and Is_Constant_Idx is returned False. + + function Has_IN_Mode (Formal : Node_Id) return Boolean is + (Ekind (Formal) = E_In_Parameter); + -- Return True if the given formal has mode IN + + ---------------------------- + -- Expr_Matches_In_Formal -- + ---------------------------- + + function Expr_Matches_In_Formal + (Subp : Entity_Id; + Subp_Call : Node_Id; + Param : Node_Id; + Skip_Controlling_Formal : Boolean := False) return Boolean + is + pragma Assert (Nkind (Subp_Call) in N_Subprogram_Call); + + Actual : Node_Id := First (Parameter_Associations (Subp_Call)); + Formal : Node_Id := First_Formal (Subp); + + begin + if Skip_Controlling_Formal then + Next_Formal (Formal); + end if; + + -- Match by position + + if Nkind (Param) /= N_Parameter_Association then + while Present (Actual) and then Present (Formal) loop + exit when Actual = Param; + Next (Actual); + + if Present (Formal) then + Next_Formal (Formal); + + -- Otherwise this is a parameter mismatch, the error is + -- reported elsewhere, or else variable indexing is implied. + + else + return False; + end if; + end loop; + + -- Match by name + + else + while Present (Formal) loop + exit when Chars (Formal) = Chars (Selector_Name (Param)); + Next_Formal (Formal); + + if No (Formal) then + return False; + end if; + end loop; + end if; + + return Present (Formal) and then Has_IN_Mode (Formal); + end Expr_Matches_In_Formal; + + ------------------------------- + -- Handle_Selected_Component -- + ------------------------------- + + procedure Handle_Selected_Component + (Current_Node : Node_Id; + Sel_Comp : Node_Id; + Candidate : out Entity_Id; + Is_Constant_Idx : out Boolean) + is + procedure Search_Constant_Interpretation + (Call : Node_Id; + Target_Name : Node_Id; + Candidate : out Entity_Id; + Is_Unique : out Boolean; + Unique_Mode : out Boolean); + -- Given a subprogram call, search in the homonyms chain for + -- visible (or potentially visible) dispatching primitives that + -- have at least one formal. Candidate is the entity of the first + -- found candidate; Is_Unique is returned True when the mode of + -- the first formal of all the candidates match. If no candidate + -- is found the out parameter Candidate is returned Empty, and + -- Is_Unique is returned False. + + procedure Search_Enclosing_Call + (Call_Node : out Node_Id; + Prev_Node : out Node_Id); + -- Climb up to the tree looking for an enclosing subprogram call + -- of a prefixed notation call. If found then the Call_Node and + -- its Prev_Node in such traversal are returned; otherwise + -- Call_Node and Prev_Node are returned Empty. + + ------------------------------------ + -- Search_Constant_Interpretation -- + ------------------------------------ + + procedure Search_Constant_Interpretation + (Call : Node_Id; + Target_Name : Node_Id; + Candidate : out Entity_Id; + Is_Unique : out Boolean; + Unique_Mode : out Boolean) + is + Constant_Idx : Boolean; + In_Proc_Call : constant Boolean := + Present (Call) + and then + Nkind (Call) = N_Procedure_Call_Statement; + Kind : constant Entity_Kind := + (if In_Proc_Call then E_Procedure + else E_Function); + Target_Subp : constant Entity_Id := + Current_Entity (Target_Name); + begin + Candidate := Empty; + Is_Unique := False; + Unique_Mode := False; + + if Present (Target_Subp) then + declare + Hom : Entity_Id := Target_Subp; + + begin + while Present (Hom) loop + if Is_Overloadable (Hom) + and then Is_Dispatching_Operation (Hom) + and then + (Is_Immediately_Visible (Scope (Hom)) + or else + Is_Potentially_Use_Visible (Scope (Hom))) + and then Ekind (Hom) = Kind + and then Present (First_Formal (Hom)) + then + if No (Candidate) then + Candidate := Hom; + Is_Unique := True; + Unique_Mode := True; + Constant_Idx := + Has_IN_Mode (First_Formal (Candidate)); + + else + Is_Unique := False; + + if Ekind (First_Formal (Hom)) + /= Ekind (First_Formal (Candidate)) + or else Has_IN_Mode (First_Formal (Hom)) + /= Constant_Idx + then + Unique_Mode := False; + exit; + end if; + end if; + end if; + + Hom := Homonym (Hom); + end loop; + end; + end if; + end Search_Constant_Interpretation; + + --------------------------- + -- Search_Enclosing_Call -- + --------------------------- + + procedure Search_Enclosing_Call + (Call_Node : out Node_Id; + Prev_Node : out Node_Id) + is + Prev : Node_Id := Current_Node; + Par : Node_Id := Parent (N); + + begin + while Present (Par) + and then Nkind (Par) not in N_Subprogram_Call + | N_Handled_Sequence_Of_Statements + | N_Assignment_Statement + | N_Iterator_Specification + | N_Object_Declaration + | N_Case_Statement + | N_Declaration + | N_Elsif_Part + | N_If_Statement + | N_Simple_Return_Statement + loop + Prev := Par; + Par := Parent (Par); + end loop; + + if Present (Par) + and then Nkind (Par) in N_Subprogram_Call + and then Nkind (Name (Par)) = N_Selected_Component + then + Call_Node := Par; + Prev_Node := Prev; + else + Call_Node := Empty; + Prev_Node := Empty; + end if; + end Search_Enclosing_Call; + + -- Local variables + + Is_Unique : Boolean; + Unique_Mode : Boolean; + Call_Node : Node_Id; + Prev_Node : Node_Id; + + -- Start of processing for Handle_Selected_Component + + begin + pragma Assert (Nkind (Sel_Comp) = N_Selected_Component); + + -- Climb up the tree starting from Current_Node searching for the + -- enclosing subprogram call of a prefixed notation call. + + Search_Enclosing_Call (Call_Node, Prev_Node); + + -- Search for a candidate visible (or potentially visible) + -- dispatching primitive that has at least one formal, and may + -- be called using the prefix notation. This must be done even + -- if we did not found an enclosing call since the prefix notation + -- call has not been transformed yet into a subprogram call. The + -- found Call_Node (if any) is passed now to help identifying if + -- the prefix notation call corresponds with a procedure call or + -- a function call. + + Search_Constant_Interpretation + (Call => Call_Node, + Target_Name => Selector_Name (Sel_Comp), + Candidate => Candidate, + Is_Unique => Is_Unique, + Unique_Mode => Unique_Mode); + + -- If there is no candidate to interpret this node as a prefixed + -- call to a subprogram we return no candidate, and the caller + -- will continue ascending in the tree. + + if No (Candidate) then + Is_Constant_Idx := False; + + -- If we found an unique candidate and also found the enclosing + -- call node, we differentiate two cases: either we climbed up + -- the tree through the first actual parameter of the call (that + -- is, the name of the selected component), or we climbed up the + -- tree though another actual parameter of the prefixed call and + -- we must skip the controlling formal of the call. + + elsif Is_Unique + and then Present (Call_Node) + then + -- First actual parameter + + if Name (Call_Node) = Prev_Node + and then Nkind (Prev_Node) = N_Selected_Component + and then Nkind (Selector_Name (Prev_Node)) in N_Has_Chars + and then Chars (Selector_Name (Prev_Node)) = Chars (Candidate) + then + Is_Constant_Idx := Has_IN_Mode (First_Formal (Candidate)); + + -- Any other actual parameter + + else + Is_Constant_Idx := + Expr_Matches_In_Formal (Candidate, + Subp_Call => Call_Node, + Param => Prev_Node, + Skip_Controlling_Formal => True); + end if; + + -- The mode of the first formal of all the candidates match but, + -- given that we have several candidates, we cannot check if + -- indexing is used in the first actual parameter of the call + -- or in another actual parameter. Heuristically assume here + -- that indexing is used in the prefix of a call. + + elsif Unique_Mode then + Heuristic := True; + Is_Constant_Idx := Has_IN_Mode (First_Formal (Candidate)); + + -- The target candidate subprogram has several possible + -- interpretations; we don't know what to do with an + -- N_Selected_Component node for a prefixed notation call + -- to AA.BB that has several candidate targets and it has + -- not yet been resolved. For now we maintain the + -- behavior that we have had so far; to be improved??? + + else + Heuristic := True; + + if Nkind (Call_Node) = N_Procedure_Call_Statement then + Is_Constant_Idx := False; + + -- For function calls we rely on the mode of the + -- first formal of the first found candidate??? + + else + Is_Constant_Idx := Has_IN_Mode (First_Formal (Candidate)); + end if; + end if; + end Handle_Selected_Component; + + -- Local variables + + Asp_Constant : constant Node_Id := + Find_Value_Of_Aspect (Pref_Typ, + Aspect_Constant_Indexing); + Asp_Variable : constant Node_Id := + Find_Value_Of_Aspect (Pref_Typ, + Aspect_Variable_Indexing); + Par : Node_Id; + + -- Start of processing for Constant_Indexing_OK begin - if No (Find_Value_Of_Aspect (Pref_Typ, Aspect_Variable_Indexing)) then + if No (Asp_Constant) then + return False; + + -- It is interpreted as constant indexing when the prefix has the + -- Constant_Indexing aspect and the Variable_Indexing aspect is not + -- specified for the type of the prefix. + + elsif No (Asp_Variable) then return True; + -- It is interpreted as constant indexing when the prefix denotes + -- a constant. + elsif not Is_Variable (Prefix) then return True; end if; + -- Both aspects are present + + pragma Assert (Present (Asp_Constant) and Present (Asp_Variable)); + + -- The prefix must be interpreted as a constant indexing when it + -- is used within a primary where a name denoting a constant is + -- permitted. + Par := N; while Present (Par) loop - if Nkind (Parent (Par)) = N_Assignment_Statement - and then Par = Name (Parent (Par)) + + -- Avoid climbing more than needed + + exit when Nkind (Parent (Par)) in N_Iterator_Specification + | N_Handled_Sequence_Of_Statements; + + if Nkind (Parent (Par)) in N_Case_Statement + | N_Declaration + | N_Elsif_Part + | N_If_Statement + | N_Simple_Return_Statement then - return False; + return True; + + -- It is not interpreted as constant indexing for the variable + -- name in the LHS of an assignment. + + elsif Nkind (Parent (Par)) = N_Assignment_Statement then + return Par /= Name (Parent (Par)); -- The call may be overloaded, in which case we assume that its -- resolution does not depend on the type of the parameter that - -- includes the indexing operation. + -- includes the indexing operation because we cannot invoke + -- Preanalyze_And_Resolve (since it would cause a never-ending + -- loop). elsif Nkind (Parent (Par)) in N_Subprogram_Call then - if not Is_Entity_Name (Name (Parent (Par))) then - - -- ??? We don't know what to do with an N_Selected_Component - -- node for a prefixed-notation call to AA.BB where AA's - -- type is known, but BB has not yet been resolved. In that - -- case, the preceding Is_Entity_Name call returns False. - -- Incorrectly returning False here will usually work - -- better than incorrectly returning True, so that's what - -- we do for now. + -- Regular subprogram call - return False; - end if; - - declare - Proc : Entity_Id; + -- It is not interpreted as constant indexing for the name + -- used for an OUT or IN OUT parameter. - begin - -- We should look for an interpretation with the proper - -- number of formals, and determine whether it is an - -- In_Parameter, but for now we examine the formal that - -- corresponds to the indexing, and assume that variable - -- indexing is required if some interpretation has an - -- assignable formal at that position. Still does not - -- cover the most complex cases ??? + -- We should look for an interpretation with the proper + -- number of formals, and determine whether it is an + -- In_Parameter, but for now we examine the formal that + -- corresponds to the indexing, and assume that variable + -- indexing is required if some interpretation has an + -- assignable formal at that position. Still does not + -- cover the most complex cases ??? + if Is_Entity_Name (Name (Parent (Par))) then if Is_Overloaded (Name (Parent (Par))) then declare Proc : constant Node_Id := Name (Parent (Par)); @@ -8617,57 +8978,103 @@ package body Sem_Ch4 is begin Get_First_Interp (Proc, I, It); while Present (It.Nam) loop - if not Expr_Matches_In_Formal (It.Nam, Par) then + if not Expr_Matches_In_Formal + (Subp => It.Nam, + Subp_Call => Parent (Par), + Param => Par) + then return False; end if; Get_Next_Interp (I, It); end loop; - end; - -- All interpretations have a matching in-mode formal + -- All interpretations have a matching in-mode formal - return True; + return True; + end; else - Proc := Entity (Name (Parent (Par))); + declare + Proc : Entity_Id := Entity (Name (Parent (Par))); - -- If this is an indirect call, get formals from - -- designated type. + begin + -- If this is an indirect call, get formals from + -- designated type. - if Is_Access_Subprogram_Type (Etype (Proc)) then - Proc := Designated_Type (Etype (Proc)); - end if; + if Is_Access_Subprogram_Type (Etype (Proc)) then + Proc := Designated_Type (Etype (Proc)); + end if; + + return Expr_Matches_In_Formal + (Subp => Proc, + Subp_Call => Parent (Par), + Param => Par); + end; end if; - return Expr_Matches_In_Formal (Proc, Par); - end; + -- Continue climbing + + elsif Nkind (Name (Parent (Par))) = N_Explicit_Dereference then + null; + + -- Not a regular call; we know that we are in a subprogram + -- call, we also know that the name of the call may be a + -- prefixed call, and we know the name of the target + -- subprogram. Search for an unique target candidate in the + -- homonym chain. + + elsif Nkind (Name (Parent (Par))) = N_Selected_Component then + declare + Candidate : Entity_Id; + Is_Constant_Idx : Boolean; + + begin + Handle_Selected_Component + (Current_Node => Par, + Sel_Comp => Name (Parent (Par)), + Candidate => Candidate, + Is_Constant_Idx => Is_Constant_Idx); + + if Present (Candidate) then + return Is_Constant_Idx; + + -- Continue climbing + + else + null; + end if; + end; + end if; + + -- It is not interpreted as constant indexing for the name in + -- an object renaming. elsif Nkind (Parent (Par)) = N_Object_Renaming_Declaration then return False; - -- If the indexed component is a prefix it may be the first actual - -- of a prefixed call. Retrieve the called entity, if any, and - -- check its first formal. Determine if the context is a procedure - -- or function call. + -- If the indexed component is a prefix it may be an actual of + -- of a prefixed call. elsif Nkind (Parent (Par)) = N_Selected_Component then declare - Sel : constant Node_Id := Selector_Name (Parent (Par)); - Nam : constant Entity_Id := Current_Entity (Sel); + Candidate : Entity_Id; + Is_Constant_Idx : Boolean; begin - if Present (Nam) and then Is_Overloadable (Nam) then - if Nkind (Parent (Parent (Par))) = - N_Procedure_Call_Statement - then - return False; + Handle_Selected_Component + (Current_Node => Par, + Sel_Comp => Parent (Par), + Candidate => Candidate, + Is_Constant_Idx => Is_Constant_Idx); - elsif Ekind (Nam) = E_Function - and then Present (First_Formal (Nam)) - then - return Ekind (First_Formal (Nam)) = E_In_Parameter; - end if; + if Present (Candidate) then + return Is_Constant_Idx; + + -- Continue climbing + + else + null; end if; end; @@ -8678,61 +9085,12 @@ package body Sem_Ch4 is Par := Parent (Par); end loop; - -- In all other cases, constant indexing is legal + -- It is not interpreted as constant indexing when both aspects + -- are present (RM 4.1.6(13/3)). - return True; + return False; end Constant_Indexing_OK; - ---------------------------- - -- Expr_Matches_In_Formal -- - ---------------------------- - - function Expr_Matches_In_Formal - (Subp : Entity_Id; - Par : Node_Id) return Boolean - is - Actual : Node_Id; - Formal : Node_Id; - - begin - Formal := First_Formal (Subp); - Actual := First (Parameter_Associations ((Parent (Par)))); - - if Nkind (Par) /= N_Parameter_Association then - - -- Match by position - - while Present (Actual) and then Present (Formal) loop - exit when Actual = Par; - Next (Actual); - - if Present (Formal) then - Next_Formal (Formal); - - -- Otherwise this is a parameter mismatch, the error is - -- reported elsewhere, or else variable indexing is implied. - - else - return False; - end if; - end loop; - - else - -- Match by name - - while Present (Formal) loop - exit when Chars (Formal) = Chars (Selector_Name (Par)); - Next_Formal (Formal); - - if No (Formal) then - return False; - end if; - end loop; - end if; - - return Present (Formal) and then Ekind (Formal) = E_In_Parameter; - end Expr_Matches_In_Formal; - ------------------------------ -- Indexing_Interpretations -- ------------------------------ @@ -8782,14 +9140,127 @@ package body Sem_Ch4 is return Indexing_Func; end Indexing_Interpretations; + --------------------------- + -- Try_Indexing_Function -- + --------------------------- + + function Try_Indexing_Function + (Func_Name : Node_Id; + Assoc : List_Id) return Entity_Id + is + Loc : constant Source_Ptr := Sloc (N); + Func : Entity_Id; + Indexing : Node_Id; + + begin + if not Is_Overloaded (Func_Name) then + Func := Entity (Func_Name); + + Indexing := + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Func, Loc), + Parameter_Associations => Assoc); + + Set_Parent (Indexing, Parent (N)); + Set_Generalized_Indexing (N, Indexing); + Analyze (Indexing); + Set_Etype (N, Etype (Indexing)); + + -- If the return type of the indexing function is a reference + -- type, add the dereference as a possible interpretation. Note + -- that the indexing aspect may be a function that returns the + -- element type with no intervening implicit dereference, and + -- that the reference discriminant is not the first discriminant. + + if Has_Discriminants (Etype (Func)) then + Check_Implicit_Dereference (N, Etype (Func)); + end if; + + else + -- If there are multiple indexing functions, build a function + -- call and analyze it for each of the possible interpretations. + + Indexing := + Make_Function_Call (Loc, + Name => + Make_Identifier (Loc, Chars (Func_Name)), + Parameter_Associations => Assoc); + Set_Parent (Indexing, Parent (N)); + Set_Generalized_Indexing (N, Indexing); + Set_Etype (N, Any_Type); + Set_Etype (Name (Indexing), Any_Type); + + declare + I : Interp_Index; + It : Interp; + Success : Boolean; + + begin + Get_First_Interp (Func_Name, I, It); + Set_Etype (Indexing, Any_Type); + + -- Analyze each candidate function with the given actuals + + while Present (It.Nam) loop + Analyze_One_Call (Indexing, It.Nam, False, Success); + Get_Next_Interp (I, It); + end loop; + + -- If there are several successful candidates, resolution will + -- be by result. Mark the interpretations of the function name + -- itself. + + if Is_Overloaded (Indexing) then + Get_First_Interp (Indexing, I, It); + + while Present (It.Nam) loop + Add_One_Interp (Name (Indexing), It.Nam, It.Typ); + Get_Next_Interp (I, It); + end loop; + + else + Set_Etype (Name (Indexing), Etype (Indexing)); + end if; + + -- Now add the candidate interpretations to the indexing node + -- itself, to be replaced later by the function call. + + if Is_Overloaded (Name (Indexing)) then + Get_First_Interp (Name (Indexing), I, It); + + while Present (It.Nam) loop + Add_One_Interp (N, It.Nam, It.Typ); + + -- Add dereference interpretation if the result type has + -- implicit reference discriminants. + + if Has_Discriminants (Etype (It.Nam)) then + Check_Implicit_Dereference (N, Etype (It.Nam)); + end if; + + Get_Next_Interp (I, It); + end loop; + + else + Set_Etype (N, Etype (Name (Indexing))); + + if Has_Discriminants (Etype (N)) then + Check_Implicit_Dereference (N, Etype (N)); + end if; + end if; + end; + end if; + + return Etype (Indexing); + end Try_Indexing_Function; + -- Local variables Loc : constant Source_Ptr := Sloc (N); Assoc : List_Id; C_Type : Entity_Id; - Func : Entity_Id; Func_Name : Node_Id; - Indexing : Node_Id; + Idx_Type : Entity_Id; -- Start of processing for Try_Container_Indexing @@ -8799,6 +9270,13 @@ package body Sem_Ch4 is if Present (Generalized_Indexing (N)) then return True; + + -- Old language version or unknown type require no action + + elsif Ada_Version < Ada_2012 + or else Pref_Typ = Any_Type + then + return False; end if; -- An explicit dereference needs to be created in the case of a prefix @@ -8833,8 +9311,8 @@ package body Sem_Ch4 is Func_Name := Empty; - -- The context is suitable for constant indexing, so obtain the name of - -- the indexing functions from aspect Constant_Indexing. + -- The context is suitable for constant indexing, so obtain the name + -- of the indexing functions from aspect Constant_Indexing. if Constant_Indexing_OK then Func_Name := @@ -8867,6 +9345,11 @@ package body Sem_Ch4 is else return False; end if; + + -- Handle cascaded errors + + elsif No (Entity (Func_Name)) then + return False; end if; Assoc := New_List (Relocate_Node (Prefix)); @@ -8907,110 +9390,54 @@ package body Sem_Ch4 is end loop; end; - if not Is_Overloaded (Func_Name) then - Func := Entity (Func_Name); - - -- Can happen in case of e.g. cascaded errors - - if No (Func) then - return False; - end if; - - Indexing := - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Func, Loc), - Parameter_Associations => Assoc); - - Set_Parent (Indexing, Parent (N)); - Set_Generalized_Indexing (N, Indexing); - Analyze (Indexing); - Set_Etype (N, Etype (Indexing)); - - -- If the return type of the indexing function is a reference type, - -- add the dereference as a possible interpretation. Note that the - -- indexing aspect may be a function that returns the element type - -- with no intervening implicit dereference, and that the reference - -- discriminant is not the first discriminant. - - if Has_Discriminants (Etype (Func)) then - Check_Implicit_Dereference (N, Etype (Func)); - end if; - - else - -- If there are multiple indexing functions, build a function call - -- and analyze it for each of the possible interpretations. - - Indexing := - Make_Function_Call (Loc, - Name => - Make_Identifier (Loc, Chars (Func_Name)), - Parameter_Associations => Assoc); - Set_Parent (Indexing, Parent (N)); - Set_Generalized_Indexing (N, Indexing); - Set_Etype (N, Any_Type); - Set_Etype (Name (Indexing), Any_Type); - + Idx_Type := Try_Indexing_Function (Func_Name, Assoc); + + -- Last chance handling for heuristics: Given that prefix notation + -- calls have not yet been resolved, when the type of the prefix has + -- both operational aspects present (Constant_Indexing and Variable_ + -- Indexing), and the analysis of the context identified a potential + -- prefix notation call (i.e. an N_Selected_Component node), the + -- evaluation of Constant_Indexing_OK is based on heuristics; in such + -- case, if the chosen indexing approach is noticed now to be wrong + -- we retry with the other alternative before leaving. + + -- Retrying means that the heuristic decision taken when analyzing + -- the context failed in this case, and therefore we should adjust + -- the code of Handle_Selected_Component to improve identification + -- of prefix notation calls. This last chance handling handler is + -- left here for the purpose of improving such routine because it + -- proved to be usefull for identified such cases when the function + -- Handle_Selected_Component was added. + + if Idx_Type = Any_Type and then Heuristic then declare - I : Interp_Index; - It : Interp; - Success : Boolean; + Tried_Func_Name : constant Node_Id := Func_Name; begin - Get_First_Interp (Func_Name, I, It); - Set_Etype (Indexing, Any_Type); - - -- Analyze each candidate function with the given actuals + Func_Name := + Indexing_Interpretations (C_Type, + Aspect_Constant_Indexing); - while Present (It.Nam) loop - Analyze_One_Call (Indexing, It.Nam, False, Success); - Get_Next_Interp (I, It); - end loop; - - -- If there are several successful candidates, resolution will - -- be by result. Mark the interpretations of the function name - -- itself. - - if Is_Overloaded (Indexing) then - Get_First_Interp (Indexing, I, It); - - while Present (It.Nam) loop - Add_One_Interp (Name (Indexing), It.Nam, It.Typ); - Get_Next_Interp (I, It); - end loop; + if Present (Func_Name) + and then Func_Name /= Tried_Func_Name + then + Idx_Type := Try_Indexing_Function (Func_Name, Assoc); else - Set_Etype (Name (Indexing), Etype (Indexing)); - end if; - - -- Now add the candidate interpretations to the indexing node - -- itself, to be replaced later by the function call. - - if Is_Overloaded (Name (Indexing)) then - Get_First_Interp (Name (Indexing), I, It); - - while Present (It.Nam) loop - Add_One_Interp (N, It.Nam, It.Typ); - - -- Add dereference interpretation if the result type has - -- implicit reference discriminants. + Func_Name := + Indexing_Interpretations (C_Type, + Aspect_Variable_Indexing); - if Has_Discriminants (Etype (It.Nam)) then - Check_Implicit_Dereference (N, Etype (It.Nam)); - end if; - - Get_Next_Interp (I, It); - end loop; - - else - Set_Etype (N, Etype (Name (Indexing))); - if Has_Discriminants (Etype (N)) then - Check_Implicit_Dereference (N, Etype (N)); + if Present (Func_Name) + and then Func_Name /= Tried_Func_Name + then + Idx_Type := Try_Indexing_Function (Func_Name, Assoc); end if; end if; end; end if; - if Etype (Indexing) = Any_Type then + if Idx_Type = Any_Type then Error_Msg_NE ("container cannot be indexed with&", N, Etype (First (Exprs))); Rewrite (N, New_Occurrence_Of (Any_Id, Loc)); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 621edc7..19e72ab 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -14696,19 +14696,18 @@ package body Sem_Prag is D := Declaration_Node (E); - if (Nkind (D) = N_Full_Type_Declaration and then Is_Array_Type (E)) + if (Nkind (D) in N_Full_Type_Declaration + | N_Formal_Type_Declaration + and then Is_Array_Type (E)) or else (Nkind (D) = N_Object_Declaration and then Ekind (E) in E_Constant | E_Variable and then Nkind (Object_Definition (D)) = N_Constrained_Array_Definition) - or else - (Ada_Version >= Ada_2022 - and then Nkind (D) = N_Formal_Type_Declaration) then -- The flag is set on the base type, or on the object - if Nkind (D) = N_Full_Type_Declaration then + if Is_Array_Type (E) then E := Base_Type (E); end if; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index b73b947..0df6c27 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6101,6 +6101,8 @@ package body Sem_Res is elsif Is_Fixed_Point_Type (It.Typ) then if Analyzed (N) then Error_Msg_N ("ambiguous operand in fixed operation", N); + elsif It.Typ = Any_Fixed then + Resolve (N, B_Typ); else Resolve (N, It.Typ); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 0e1505b..7757e04 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -3025,7 +3025,7 @@ package body Sem_Util is -- For an array aggregate, a discrete_choice_list that has -- a nonstatic range is considered as two or more separate - -- occurrences of the expression (RM 6.4.1(20/3)). + -- occurrences of the expression (RM 6.4.1(6.20/3)). elsif Is_Array_Type (Etype (N)) and then Nkind (N) = N_Aggregate @@ -3110,48 +3110,105 @@ package body Sem_Util is end loop; end if; - -- Handle discrete associations + -- Handle named associations if Present (Component_Associations (N)) then Assoc := First (Component_Associations (N)); while Present (Assoc) loop - if not Box_Present (Assoc) then - Choice := First (Choices (Assoc)); - while Present (Choice) loop + Handle_Association : declare - -- For now we skip discriminants since it requires - -- performing the analysis in two phases: first one - -- analyzing discriminants and second one analyzing - -- the rest of components since discriminants are - -- evaluated prior to components: too much extra - -- work to detect a corner case??? + procedure Collect_Expression_Ids (Expr : Node_Id); + -- Collect identifiers in association expression Expr - if Nkind (Choice) in N_Has_Entity - and then Present (Entity (Choice)) - and then Ekind (Entity (Choice)) = E_Discriminant - then - null; + procedure Handle_Association_Choices + (Choices : List_Id; Expr : Node_Id); + -- Collect identifiers in an association expression + -- Expr for each choice in Choices. - elsif Box_Present (Assoc) then - null; + ---------------------------- + -- Collect_Expression_Ids -- + ---------------------------- + procedure Collect_Expression_Ids (Expr : Node_Id) is + Comp_Expr : Node_Id; + + begin + if not Analyzed (Expr) then + Comp_Expr := New_Copy_Tree (Expr); + Set_Parent (Comp_Expr, Parent (N)); + Preanalyze_Without_Errors (Comp_Expr); else - if not Analyzed (Expression (Assoc)) then - Comp_Expr := - New_Copy_Tree (Expression (Assoc)); - Set_Parent (Comp_Expr, Parent (N)); - Preanalyze_Without_Errors (Comp_Expr); + Comp_Expr := Expr; + end if; + + Collect_Identifiers (Comp_Expr); + end Collect_Expression_Ids; + + -------------------------------- + -- Handle_Association_Choices -- + -------------------------------- + + procedure Handle_Association_Choices + (Choices : List_Id; Expr : Node_Id) + is + Choice : Node_Id := First (Choices); + + begin + while Present (Choice) loop + + -- For now skip discriminants since it requires + -- performing analysis in two phases: first one + -- analyzing discriminants and second analyzing + -- the rest of components since discriminants + -- are evaluated prior to components: too much + -- extra work to detect a corner case??? + + if Nkind (Choice) in N_Has_Entity + and then Present (Entity (Choice)) + and then + Ekind (Entity (Choice)) = E_Discriminant + then + null; + else - Comp_Expr := Expression (Assoc); + Collect_Expression_Ids (Expr); end if; - Collect_Identifiers (Comp_Expr); - end if; + Next (Choice); + end loop; + end Handle_Association_Choices; - Next (Choice); - end loop; - end if; + begin + if not Box_Present (Assoc) then + if Nkind (Assoc) = N_Component_Association then + Handle_Association_Choices + (Choices (Assoc), Expression (Assoc)); + + elsif + Nkind (Assoc) = N_Iterated_Component_Association + and then Present (Defining_Identifier (Assoc)) + then + Handle_Association_Choices + (Discrete_Choices (Assoc), Expression (Assoc)); + + -- Nkind (Assoc) = N_Iterated_Component_Association + -- with iterator_specification, or + -- Nkind (Assoc) = N_Iterated_Element_Association + -- with loop_parameter_specification + -- or iterator_specification + -- + -- It seems that we might also need to deal with + -- iterable/iterator_names and iterator_filters + -- within iterator_specifications, and range bounds + -- within loop_parameter_specifications, but the + -- utility of doing that seems very low. ??? + + else + Collect_Expression_Ids (Expression (Assoc)); + end if; + end if; + end Handle_Association; Next (Assoc); end loop; @@ -8063,12 +8120,20 @@ package body Sem_Util is loop Ren := Renamed_Object (Id); + -- The reference renames a function result. Check the original + -- node in case expansion relocates the function call. + + -- Ren : ... renames Func_Call; + + if Nkind (Original_Node (Ren)) = N_Function_Call then + exit; + -- The reference renames an abstract state or a whole object -- Obj : ...; -- Ren : ... renames Obj; - if Is_Entity_Name (Ren) then + elsif Is_Entity_Name (Ren) then -- Do not follow a renaming that goes through a generic formal, -- because these entities are hidden and must not be referenced @@ -8081,14 +8146,6 @@ package body Sem_Util is Id := Entity (Ren); end if; - -- The reference renames a function result. Check the original - -- node in case expansion relocates the function call. - - -- Ren : ... renames Func_Call; - - elsif Nkind (Original_Node (Ren)) = N_Function_Call then - exit; - -- Otherwise the reference renames something which does not yield -- an abstract state or a whole object. Treat the reference as not -- having a proper entity for SPARK legality purposes. @@ -12368,9 +12425,14 @@ package body Sem_Util is while Present (Node) loop case Nkind (Node) is - when N_Null_Statement | N_Call_Marker | N_Raise_xxx_Error => + when N_Null_Statement | N_Call_Marker => null; + when N_Raise_xxx_Error => + if Comes_From_Source (Node) then + return False; + end if; + when N_Object_Declaration => if Present (Expression (Node)) and then not Side_Effect_Free (Expression (Node)) |