diff options
| -rw-r--r-- | gcc/ada/checks.adb | 55 | ||||
| -rw-r--r-- | gcc/ada/einfo.ads | 10 | ||||
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_ch6.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/exp_util.adb | 181 | ||||
| -rw-r--r-- | gcc/ada/exp_util.ads | 6 | ||||
| -rw-r--r-- | gcc/ada/gen_il-fields.ads | 2 | ||||
| -rw-r--r-- | gcc/ada/gen_il-gen-gen_entities.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/par-ch3.adb | 207 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 90 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_util.adb | 30 | ||||
| -rw-r--r-- | gcc/ada/sprint.adb | 8 |
13 files changed, 587 insertions, 25 deletions
diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index b46526e..8c4667c 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -10506,16 +10506,36 @@ package body Checks is LB := New_Occurrence_Of (Discriminal (Entity (LB)), Loc); end if; - Left_Opnd := - Make_Op_Lt (Loc, - Left_Opnd => - Convert_To - (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)), + -- If the index type has a fixed lower bound, then we require an + -- exact match of the range's lower bound against that fixed lower + -- bound. - Right_Opnd => - Convert_To - (Base_Type (Typ), - Get_E_First_Or_Last (Loc, Typ, 0, Name_First))); + if Is_Fixed_Lower_Bound_Index_Subtype (Typ) then + Left_Opnd := + Make_Op_Ne (Loc, + Left_Opnd => + Convert_To + (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)), + + Right_Opnd => + Convert_To + (Base_Type (Typ), + Get_E_First_Or_Last (Loc, Typ, 0, Name_First))); + + -- Otherwise we do the expected less-than comparison + + else + Left_Opnd := + Make_Op_Lt (Loc, + Left_Opnd => + Convert_To + (Base_Type (Typ), Duplicate_Subexpr_No_Checks (LB)), + + Right_Opnd => + Convert_To + (Base_Type (Typ), + Get_E_First_Or_Last (Loc, Typ, 0, Name_First))); + end if; if Nkind (HB) = N_Identifier and then Ekind (Entity (HB)) = E_Discriminant @@ -10821,6 +10841,22 @@ package body Checks is end if; end if; + -- Flag the case of a fixed-lower-bound index where the static + -- bounds are not equal. + + if not Check_Added + and then Is_Fixed_Lower_Bound_Index_Subtype (T_Typ) + and then Expr_Value (LB) /= Expr_Value (T_LB) + then + Add_Check + (Compile_Time_Constraint_Error + ((if Present (Warn_Node) + then Warn_Node else Low_Bound (Expr)), + "static value does not equal lower bound of}??", + T_Typ)); + Check_Added := True; + end if; + if Known_HB then if Known_T_HB then Out_Of_Range_H := T_HB < HB; @@ -10972,7 +11008,6 @@ package body Checks is if Is_Array_Type (T_Typ) and then Is_Array_Type (S_Typ) then if Is_Constrained (T_Typ) then - Expr_Actual := Get_Referenced_Object (Expr); Exptyp := Get_Actual_Subtype (Expr_Actual); diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index fe9bf72..55cf83d 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -2589,6 +2589,16 @@ package Einfo is -- an anonymous base type (e.g. for integer type declarations or -- constrained array declarations). +-- Is_Fixed_Lower_Bound_Array_Subtype +-- Defined in type entities. True for unconstrained array types and +-- subtypes where at least one index has a range specified with a fixed +-- lower bound (range syntax is "<expression> .. <>"). + +-- Is_Fixed_Lower_Bound_Index_Subtype +-- Defined in type entities. True for an index of an unconstrained array +-- type or subtype whose range is specified with a fixed lower bound +-- (range syntax is "<expression> .. <>"). + -- Is_Fixed_Point_Type (synthesized) -- Applies to all entities, true for decimal and ordinary fixed -- point types and subtypes. diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 4436557..1d04a06 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -12585,6 +12585,13 @@ package body Exp_Ch4 is if Is_Constrained (Target_Type) then Apply_Length_Check (Operand, Target_Type); else + -- If the object has an unconstrained array subtype with fixed + -- lower bound, then sliding to that bound may be needed. + + if Is_Fixed_Lower_Bound_Array_Subtype (Target_Type) then + Expand_Sliding_Conversion (Operand, Target_Type); + end if; + Apply_Range_Check (Operand, Target_Type); end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index b5d77bd..6314b0a 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -7534,6 +7534,13 @@ package body Exp_Ch6 is Suppress => All_Checks); end if; + -- If the result is of an unconstrained array subtype with fixed lower + -- bound, then sliding to that bound may be needed. + + if Is_Fixed_Lower_Bound_Array_Subtype (R_Type) then + Expand_Sliding_Conversion (Exp, R_Type); + end if; + -- If we are returning a nonscalar object that is possibly unaligned, -- then copy the value into a temporary first. This copy may need to -- expand to a loop of component operations. diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 71052c0..19b8c65 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -37,6 +37,7 @@ with Exp_Aggr; use Exp_Aggr; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch11; use Exp_Ch11; +with Freeze; use Freeze; with Ghost; use Ghost; with Inline; use Inline; with Itypes; use Itypes; @@ -5315,6 +5316,186 @@ package body Exp_Util is end if; end Evolve_Or_Else; + ------------------------------- + -- Expand_Sliding_Conversion -- + ------------------------------- + + procedure Expand_Sliding_Conversion (N : Node_Id; Arr_Typ : Entity_Id) is + + pragma Assert (Is_Array_Type (Arr_Typ) + and then not Is_Constrained (Arr_Typ)); + + Constraints : List_Id; + Index : Node_Id := First_Index (Arr_Typ); + Loc : constant Source_Ptr := Sloc (N); + Subt_Decl : Node_Id; + Subt : Entity_Id; + Subt_Low : Node_Id; + Subt_High : Node_Id; + + Act_Subt : Entity_Id; + Act_Index : Node_Id; + Act_Low : Node_Id; + Act_High : Node_Id; + Adjust_Incr : Node_Id; + Dimension : Int := 0; + All_FLBs_Match : Boolean := True; + + begin + if Is_Fixed_Lower_Bound_Array_Subtype (Arr_Typ) then + Constraints := New_List; + + Act_Subt := Get_Actual_Subtype (N); + Act_Index := First_Index (Act_Subt); + + -- Loop over the indexes of the fixed-lower-bound array type or + -- subtype to build up an index constraint for constructing the + -- subtype that will be the target of a conversion of the array + -- object that may need a sliding conversion. + + while Present (Index) loop + pragma Assert (Present (Act_Index)); + + Dimension := Dimension + 1; + + Get_Index_Bounds (Act_Index, Act_Low, Act_High); + + -- If Index defines a normal unconstrained range (range <>), + -- then we will simply use the bounds of the actual subtype's + -- corresponding index range. + + if not Is_Fixed_Lower_Bound_Index_Subtype (Etype (Index)) then + Subt_Low := Act_Low; + Subt_High := Act_High; + + -- Otherwise, a range will be created with a low bound given by + -- the fixed lower bound of the array subtype's index, and with + -- high bound given by (Actual'Length + fixed lower bound - 1). + + else + if Nkind (Index) = N_Subtype_Indication then + Subt_Low := + New_Copy_Tree + (Low_Bound (Range_Expression (Constraint (Index)))); + else + pragma Assert (Nkind (Index) = N_Range); + + Subt_Low := New_Copy_Tree (Low_Bound (Index)); + end if; + + -- If either we have a nonstatic lower bound, or the target and + -- source subtypes are statically known to have unequal lower + -- bounds, then we will need to make a subtype conversion to + -- slide the bounds. However, if all of the indexes' lower + -- bounds are static and known to be equal (the common case), + -- then no conversion will be needed, and we'll end up not + -- creating the subtype or the conversion (though we still + -- build up the index constraint, which will simply be unused). + + if not (Compile_Time_Known_Value (Subt_Low) + and then Compile_Time_Known_Value (Act_Low)) + or else Expr_Value (Subt_Low) /= Expr_Value (Act_Low) + then + All_FLBs_Match := False; + end if; + + -- Apply 'Pos to lower bound, which may be of an enumeration + -- type, before subtracting. + + Adjust_Incr := + Make_Op_Subtract (Loc, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Etype (Act_Index), Loc), + Attribute_Name => + Name_Pos, + Expressions => + New_List (New_Copy_Tree (Subt_Low))), + Make_Integer_Literal (Loc, 1)); + + -- Apply 'Val to the result of adding the increment to the + -- length, to handle indexes of enumeration types. + + Subt_High := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Etype (Act_Index), Loc), + Attribute_Name => + Name_Val, + Expressions => + New_List (Make_Op_Add (Loc, + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Act_Subt, Loc), + Attribute_Name => + Name_Length, + Expressions => + New_List + (Make_Integer_Literal + (Loc, Dimension))), + Adjust_Incr))); + end if; + + Append (Make_Range (Loc, Subt_Low, Subt_High), Constraints); + + Next (Index); + Next (Act_Index); + end loop; + + -- If for each index with a fixed lower bound (FLB), the lower bound + -- of the corresponding index of the actual subtype is statically + -- known be equal to the FLB, then a sliding conversion isn't needed + -- at all, so just return without building a subtype or conversion. + + if All_FLBs_Match then + return; + end if; + + -- A sliding conversion is needed, so create the target subtype using + -- the index constraint created above, and rewrite the expression + -- as a conversion to that subtype. + + Subt := Make_Temporary (Loc, 'S', Related_Node => N); + Set_Is_Internal (Subt); + + Subt_Decl := + Make_Subtype_Declaration (Loc, + Defining_Identifier => Subt, + Subtype_Indication => + Make_Subtype_Indication (Loc, + Subtype_Mark => + New_Occurrence_Of (Arr_Typ, Loc), + Constraint => + Make_Index_Or_Discriminant_Constraint (Loc, + Constraints => Constraints))); + + Mark_Rewrite_Insertion (Subt_Decl); + + -- The actual subtype is an Itype, so we analyze the declaration, + -- but do not attach it to the tree. + + Set_Parent (Subt_Decl, N); + Set_Is_Itype (Subt); + Analyze (Subt_Decl, Suppress => All_Checks); + Set_Associated_Node_For_Itype (Subt, N); + Set_Has_Delayed_Freeze (Subt, False); + + -- We need to freeze the actual subtype immediately. This is needed + -- because otherwise this Itype will not get frozen at all, and it is + -- always safe to freeze on creation because any associated types + -- must be frozen at this point. + + Freeze_Itype (Subt, N); + + Rewrite (N, + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Subt, Loc), + Expression => Relocate_Node (N))); + Analyze (N); + end if; + end Expand_Sliding_Conversion; + ----------------------------------------- -- Expand_Static_Predicates_In_Choices -- ----------------------------------------- diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 85e5a55..2b3147d 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -560,6 +560,12 @@ package Exp_Util is -- indicating that no checks were required). The Sloc field of the -- constructed N_Or_Else node is copied from Cond1. + procedure Expand_Sliding_Conversion (N : Node_Id; Arr_Typ : Entity_Id); + -- When sliding is needed for an array object N in the context of an + -- unconstrained array type Arr_Typ with fixed lower bound (FLB), create + -- a subtype with appropriate index constraint (FLB .. N'Length + FLB - 1) + -- and apply a conversion from N to that subtype. + procedure Expand_Static_Predicates_In_Choices (N : Node_Id); -- N is either a case alternative or a variant. The Discrete_Choices field -- of N points to a list of choices. If any of these choices is the name diff --git a/gcc/ada/gen_il-fields.ads b/gcc/ada/gen_il-fields.ads index 91a610a..4aac802 100644 --- a/gcc/ada/gen_il-fields.ads +++ b/gcc/ada/gen_il-fields.ads @@ -705,6 +705,8 @@ package Gen_IL.Fields is Is_Exported, Is_Finalized_Transient, Is_First_Subtype, + Is_Fixed_Lower_Bound_Array_Subtype, + Is_Fixed_Lower_Bound_Index_Subtype, Is_Formal_Subprogram, Is_Frozen, Is_Generic_Actual_Subprogram, diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb index 85eb2d7..afd3ec4 100644 --- a/gcc/ada/gen_il-gen-gen_entities.adb +++ b/gcc/ada/gen_il-gen-gen_entities.adb @@ -532,6 +532,8 @@ begin -- Gen_IL.Gen.Gen_Entities Sm (Is_Abstract_Type, Flag), Sm (Is_Actual_Subtype, Flag), Sm (Is_Asynchronous, Flag), + Sm (Is_Fixed_Lower_Bound_Array_Subtype, Flag), + Sm (Is_Fixed_Lower_Bound_Index_Subtype, Flag), Sm (Is_Generic_Actual_Type, Flag), Sm (Is_Non_Static_Subtype, Flag), Sm (Is_Private_Composite, Flag), diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 2a79599..52e52dc 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -2693,6 +2693,73 @@ package body Ch3 is Scan_State : Saved_Scan_State; Aliased_Present : Boolean := False; + procedure P_Index_Subtype_Def_With_Fixed_Lower_Bound + (Subtype_Mark : Node_Id); + -- Parse an unconstrained index range with a fixed lower bound: + -- subtype_mark range <expression> .. <> + -- This procedure creates a subtype_indication node for the index. + + -------------------------------------------- + -- P_Index_Range_With_Fixed_Lower_Bound -- + -------------------------------------------- + + procedure P_Index_Subtype_Def_With_Fixed_Lower_Bound + (Subtype_Mark : Node_Id) + is + Low_Expr_Node : constant Node_Id := P_Expression; + High_Expr_Node : Node_Id; + Indic_Node : Node_Id; + Constr_Node : Node_Id; + Range_Node : Node_Id; + + begin + T_Dot_Dot; -- Error if no .. + + -- A box is required at this point, and we'll set the upper bound to + -- the same expression as the lower bound (see further below), to + -- avoid problems with trying to analyze an Empty node. Analysis can + -- still tell that this is a fixed-lower-bound range because the + -- index is represented by a subtype_indication in an unconstrained + -- array type definition. + + if Token = Tok_Box then + Scan; + High_Expr_Node := Low_Expr_Node; + + -- Error if no <> was found, and try to parse an expression since + -- it's likely one was given in place of the <>. + + else + Error_Msg_AP -- CODEFIX + ("missing ""'<'>"""); + + High_Expr_Node := P_Expression; + end if; + + Constr_Node := New_Node (N_Range_Constraint, Token_Ptr); + Range_Node := New_Node (N_Range, Token_Ptr); + Set_Range_Expression (Constr_Node, Range_Node); + + Check_Simple_Expression (Low_Expr_Node); + + Set_Low_Bound (Range_Node, Low_Expr_Node); + Set_High_Bound (Range_Node, High_Expr_Node); + + Indic_Node := + New_Node (N_Subtype_Indication, Sloc (Subtype_Mark)); + Set_Subtype_Mark (Indic_Node, Check_Subtype_Mark (Subtype_Mark)); + Set_Constraint (Indic_Node, Constr_Node); + + Append (Indic_Node, Subs_List); + end P_Index_Subtype_Def_With_Fixed_Lower_Bound; + + -- Local variables + + Is_Constrained_Array_Def : Boolean := True; + Subtype_Mark_Node : Node_Id; + + -- Start of processing for P_Array_Type_Definition + begin Array_Loc := Token_Ptr; Scan; -- past ARRAY @@ -2724,17 +2791,125 @@ package body Ch3 is Def_Node := New_Node (N_Unconstrained_Array_Definition, Array_Loc); Restore_Scan_State (Scan_State); -- to first subtype mark + Is_Constrained_Array_Def := False; + + -- Now parse a sequence of indexes where each is either of form: + -- <subtype_mark> range <> + -- or + -- <subtype_mark> range <expr> .. <> + -- + -- The latter syntax indicates an index with a fixed lower bound, + -- and only applies when extensions are enabled (-gnatX). + loop - Append (P_Subtype_Mark_Resync, Subs_List); + Subtype_Mark_Node := P_Subtype_Mark_Resync; + T_Range; - T_Box; + + -- Normal "subtype_mark range <>" form, so simply append + -- the subtype reference. + + if Token = Tok_Box then + Append (Subtype_Mark_Node, Subs_List); + Scan; + + -- Fixed-lower-bound form ("subtype_mark range <expr> .. <>") + + else + P_Index_Subtype_Def_With_Fixed_Lower_Bound (Subtype_Mark_Node); + + if not Extensions_Allowed then + Error_Msg_N + ("fixed-lower-bound array is an extension feature; " + & "use -gnatX", + Token_Node); + end if; + end if; + exit when Token = Tok_Right_Paren or else Token = Tok_Of; T_Comma; end loop; Set_Subtype_Marks (Def_Node, Subs_List); - else + -- If we don't have "range <>", then "range" will be followed by an + -- expression, for either a normal range or a fixed-lower-bound range + -- ("<exp> .. <>"), and we have to know which, in order to determine + -- whether to parse the indexes for an unconstrained or constrained + -- array definition. So we look ahead to see if "<>" follows the "..". + -- If not, then this must be a discrete_subtype_indication for a + -- constrained_array_definition, which will be processed further below. + + elsif Prev_Token = Tok_Range + and then Token /= Tok_Right_Paren and then Token /= Tok_Comma + then + -- If we have an expression followed by "..", then scan farther + -- and check for "<>" to see if we have a fixed-lower-bound range. + + if P_Expression_Or_Range_Attribute /= Error + and then Expr_Form /= EF_Range_Attr + and then Token = Tok_Dot_Dot + then + Scan; + + -- If there's a "<>", then we know we have a fixed-lower-bound + -- index, so we can proceed with parsing an unconstrained array + -- definition. + + if Token = Tok_Box then + Is_Constrained_Array_Def := False; + + Def_Node := + New_Node (N_Unconstrained_Array_Definition, Array_Loc); + + Restore_Scan_State (Scan_State); -- to first subtype mark + + -- Now parse a sequence of indexes where each is either of + -- form: + -- <subtype_mark> range <> + -- or + -- <subtype_mark> range <expr> .. <> + -- + -- The latter indicates an index with a fixed lower bound, + -- and only applies when extensions are enabled (-gnatX). + + loop + Subtype_Mark_Node := P_Subtype_Mark_Resync; + + T_Range; + + -- Normal "subtype_mark range <>" form, so simply append + -- the subtype reference. + + if Token = Tok_Box then + Append (Subtype_Mark_Node, Subs_List); + Scan; + + -- This must be an index of form: + -- <subtype_mark> range <expr> .. <>" + + else + P_Index_Subtype_Def_With_Fixed_Lower_Bound + (Subtype_Mark_Node); + + if not Extensions_Allowed then + Error_Msg_N + ("fixed-lower-bound array is an extension feature; " + & "use -gnatX", + Token_Node); + end if; + end if; + + exit when Token = Tok_Right_Paren or else Token = Tok_Of; + T_Comma; + end loop; + + Set_Subtype_Marks (Def_Node, Subs_List); + end if; + end if; + end if; + + if Is_Constrained_Array_Def then Def_Node := New_Node (N_Constrained_Array_Definition, Array_Loc); Restore_Scan_State (Scan_State); -- to first discrete range @@ -3217,8 +3392,30 @@ package body Ch3 is Constr_Node := New_Node (N_Range, Token_Ptr); Set_Low_Bound (Constr_Node, Expr_Node); Scan; -- past .. - Expr_Node := P_Expression; - Check_Simple_Expression (Expr_Node); + + -- If the upper bound is given by "<>", this is an index for + -- a fixed-lower-bound subtype, so set the expression to Empty + -- for now (it will be set to the ranges maximum upper bound + -- later during analysis), and scan to the next token. + + if Token = Tok_Box then + if not Extensions_Allowed then + Error_Msg_N + ("fixed-lower-bound array is an extension feature; " + & "use -gnatX", + Expr_Node); + end if; + + Expr_Node := Empty; + Scan; + + -- Otherwise parse the range's upper bound expression + + else + Expr_Node := P_Expression; + Check_Simple_Expression (Expr_Node); + end if; + Set_High_Bound (Constr_Node, Expr_Node); Append (Constr_Node, Constr_List); goto Loop_Continue; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 8d25a97..6720d41 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -4620,6 +4620,13 @@ package body Sem_Ch3 is Related_Id := Empty; end if; + -- If the object has an unconstrained array subtype with fixed + -- lower bound, then sliding to that bound may be needed. + + if Is_Fixed_Lower_Bound_Array_Subtype (T) then + Expand_Sliding_Conversion (E, T); + end if; + Expand_Subtype_From_Expr (N => N, Unc_Type => T, @@ -6024,6 +6031,7 @@ package body Sem_Ch3 is Nb_Index : Pos; Priv : Entity_Id; Related_Id : Entity_Id; + Has_FLB_Index : Boolean := False; begin if Nkind (Def) = N_Constrained_Array_Definition then @@ -6113,6 +6121,39 @@ package body Sem_Ch3 is Make_Index (Index, P, Related_Id, Nb_Index); + -- In the case where we have an unconstrained array with an index + -- given by a subtype_indication, this is necessarily a "fixed lower + -- bound" index. We change the upper bound of that index to the upper + -- bound of the index's subtype (denoted by the subtype_mark), since + -- that upper bound was originally set by the parser to be the same + -- as the lower bound. In truth, that upper bound corresponds to + -- a box ("<>"), and could be set to Empty, but it's convenient to + -- set it to the upper bound to avoid needing to add special tests + -- in various places for an Empty upper bound, and in any case that + -- accurately characterizes the index's range of values. + + if Nkind (Def) = N_Unconstrained_Array_Definition + and then Nkind (Index) = N_Subtype_Indication + then + declare + Index_Subtype_High_Bound : constant Entity_Id := + Type_High_Bound (Entity (Subtype_Mark (Index))); + begin + Set_High_Bound (Range_Expression (Constraint (Index)), + Index_Subtype_High_Bound); + + -- Record that the array type has one or more indexes with + -- a fixed lower bound. + + Has_FLB_Index := True; + + -- Mark the index as belonging to an array type with a fixed + -- lower bound. + + Set_Is_Fixed_Lower_Bound_Index_Subtype (Etype (Index)); + end; + end if; + -- Check error of subtype with predicate for index type Bad_Predicated_Subtype_Use @@ -6241,6 +6282,8 @@ package body Sem_Ch3 is Set_Scope (T, Current_Scope); Set_Component_Size (T, Uint_0); Set_Is_Constrained (T, False); + Set_Is_Fixed_Lower_Bound_Array_Subtype + (T, Has_FLB_Index); Set_First_Index (T, First (Subtype_Marks (Def))); Set_Has_Delayed_Freeze (T, True); Propagate_Concurrent_Flags (T, Element_Type); @@ -13270,6 +13313,7 @@ package body Sem_Ch3 is Index : Node_Id; S, T : Entity_Id; Constraint_OK : Boolean := True; + Is_FLB_Array_Subtype : Boolean := False; begin T := Entity (Subtype_Mark (SI)); @@ -13313,6 +13357,16 @@ package body Sem_Ch3 is for J in 1 .. Number_Of_Constraints loop Constrain_Index (Index, S, Related_Nod, Related_Id, Suffix, J); + + -- If the subtype of the index has been set to indicate that + -- it has a fixed lower bound, then record that the subtype's + -- entity will need to be marked as being a fixed-lower-bound + -- array subtype. + + if Is_Fixed_Lower_Bound_Index_Subtype (Etype (S)) then + Is_FLB_Array_Subtype := True; + end if; + Next (Index); Next (S); end loop; @@ -13339,7 +13393,9 @@ package body Sem_Ch3 is Set_First_Index (Def_Id, First_Index (T)); end if; - Set_Is_Constrained (Def_Id, True); + Set_Is_Constrained (Def_Id, not Is_FLB_Array_Subtype); + Set_Is_Fixed_Lower_Bound_Array_Subtype + (Def_Id, Is_FLB_Array_Subtype); Set_Is_Aliased (Def_Id, Is_Aliased (T)); Set_Is_Independent (Def_Id, Is_Independent (T)); Set_Depends_On_Private (Def_Id, Has_Private_Component (Def_Id)); @@ -14201,6 +14257,7 @@ package body Sem_Ch3 is Def_Id : Entity_Id; R : Node_Id := Empty; T : constant Entity_Id := Etype (Index); + Is_FLB_Index : Boolean := False; begin Def_Id := @@ -14214,6 +14271,20 @@ package body Sem_Ch3 is then -- A Range attribute will be transformed into N_Range by Resolve + -- If a range has an Empty upper bound, then remember that for later + -- setting of the index subtype's Is_Fixed_Lower_Bound_Index_Subtype + -- flag, and also set the upper bound of the range to the index + -- subtype's upper bound rather than leaving it Empty. In truth, + -- that upper bound corresponds to a box ("<>"), but it's convenient + -- to set it to the upper bound to avoid needing to add special tests + -- in various places for an Empty upper bound, and in any case it + -- accurately characterizes the index's range of values. + + if Nkind (S) = N_Range and then not Present (High_Bound (S)) then + Is_FLB_Index := True; + Set_High_Bound (S, Type_High_Bound (T)); + end if; + R := S; Process_Range_Expr_In_Decl (R, T); @@ -14314,7 +14385,22 @@ package body Sem_Ch3 is Set_RM_Size (Def_Id, RM_Size (T)); Set_First_Rep_Item (Def_Id, First_Rep_Item (T)); - Set_Scalar_Range (Def_Id, R); + -- If this is a range for a fixed-lower-bound subtype, then set the + -- index itype's lower bound to the FLB and the index type's upper bound + -- to the high bound of the index base type's high bound, mark the itype + -- as an FLB index subtype, and set the range's Etype to the itype. + + if Nkind (S) = N_Range and then Is_FLB_Index then + Set_Scalar_Range + (Def_Id, + Make_Range (Sloc (S), + Low_Bound => Low_Bound (S), + High_Bound => Type_High_Bound (Base_Type (T)))); + Set_Is_Fixed_Lower_Bound_Index_Subtype (Def_Id); + + else + Set_Scalar_Range (Def_Id, R); + end if; Set_Etype (S, Def_Id); Set_Discrete_RM_Size (Def_Id); diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 32e71cc..720f170 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -4773,6 +4773,13 @@ package body Sem_Res is -- Expand_Actuals routine in Exp_Ch6. end if; + -- If the formal is of an unconstrained array subtype with fixed + -- lower bound, then sliding to that bound may be needed. + + if Is_Fixed_Lower_Bound_Array_Subtype (F_Typ) then + Expand_Sliding_Conversion (A, F_Typ); + end if; + -- An actual associated with an access parameter is implicitly -- converted to the anonymous access type of the formal and must -- satisfy the legality checks for access conversions. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 47b6a93..d0e3b1a 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1683,6 +1683,7 @@ package body Sem_Util is Subt : Entity_Id; Disc_Type : Entity_Id; Obj : Node_Id; + Index : Node_Id; begin Loc := Sloc (N); @@ -1713,6 +1714,8 @@ package body Sem_Util is if Is_Array_Type (T) then Constraints := New_List; + Index := First_Index (T); + for J in 1 .. Number_Dimensions (T) loop -- Build an array subtype declaration with the nominal subtype and @@ -1720,13 +1723,24 @@ package body Sem_Util is -- local declarations for the subprogram, for analysis before any -- reference to the formal in the body. - Lo := - Make_Attribute_Reference (Loc, - Prefix => - Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), - Attribute_Name => Name_First, - Expressions => New_List ( - Make_Integer_Literal (Loc, J))); + -- If this is for an index with a fixed lower bound, then use + -- the fixed lower bound as the lower bound of the actual + -- subtype's corresponding index. + + if not Is_Constrained (T) + and then Is_Fixed_Lower_Bound_Index_Subtype (Etype (Index)) + then + Lo := New_Copy_Tree (Type_Low_Bound (Etype (Index))); + + else + Lo := + Make_Attribute_Reference (Loc, + Prefix => + Duplicate_Subexpr_No_Checks (Obj, Name_Req => True), + Attribute_Name => Name_First, + Expressions => New_List ( + Make_Integer_Literal (Loc, J))); + end if; Hi := Make_Attribute_Reference (Loc, @@ -1737,6 +1751,8 @@ package body Sem_Util is Make_Integer_Literal (Loc, J))); Append (Make_Range (Loc, Lo, Hi), Constraints); + + Next_Index (Index); end loop; -- If the type has unknown discriminants there is no constrained diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index 2eeea52..5f2d027 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -3072,7 +3072,13 @@ package body Sprint is when N_Range => Sprint_Node (Low_Bound (Node)); Write_Str_Sloc (" .. "); - Sprint_Node (High_Bound (Node)); + if Present (Etype (Node)) + and then Is_Fixed_Lower_Bound_Index_Subtype (Etype (Node)) + then + Write_Str ("<>"); + else + Sprint_Node (High_Bound (Node)); + end if; Update_Itype (Node); when N_Range_Constraint => |