From d32db3a763249a8b94c2e2e285fc6f400eadea4e Mon Sep 17 00:00:00 2001 From: Gary Dismukes Date: Fri, 5 Mar 2021 02:20:09 -0500 Subject: [PATCH] [Ada] Implementation of Inox feature of fixed lower bounds on array types/subtypes gcc/ada/ * checks.adb (Discrete_Range_Cond): For an index subtype that has a fixed lower bound, require that the range's lower bound match that of the subtype. (Selected_Range_Checks): Warn about the case where a static lower bound does not equal an index subtype's fixed lower bound. * einfo.ads (Is_Fixed_Lower_Bound_Array_Subtype, Is_Fixed_Lower_Bound_Index_Subtype): Document new entity flag. * exp_ch4.adb (Expand_N_Type_Conversion): If the operand is of an unconstrained array subtype with fixed lower bound, then Expand_Sliding_Conversion is applied to the operand. * exp_ch6.adb (Expand_Simple_Function_Return): If the result subtype is an unconstrained array subtype with fixed lower bound, then Expand_Sliding_Conversion is applied to the return object. * exp_util.ads (Expand_Sliding_Conversion): New procedure for applying a sliding subtype conversion to an array object of a fixed-lower-bound subtype when needed. * exp_util.adb: Add with_clause for Freeze. (Expand_Sliding_Conversion): New procedure for applying a sliding subtype conversion to an array object of a fixed-lower-bound subtype when needed. It traverses the indexes of the unconstrained array type/subtype to create a target constrained subtype and rewrites the array object to be a conversion to that subtype, when there's at least one index whose lower bound does not statically match the fixed-lower bound of the target subtype. * gen_il-fields.ads (type Opt_Field_Enum): Add literals Is_Fixed_Lower_Bound_Array_Subtype and Is_Fixed_Lower_Bound_Index_Subtype for new flags on type entities. * gen_il-gen-gen_entities.adb: Add calls to Create_Semantic_Field for the new fixed-lower-bound flags on type entities. * par-ch3.adb (P_Array_Type_Definition): Add handling for parsing of fixed-lower-bound index ranges in unconstrained array types. Report an error if such an index is encountered and GNAT language extensions are not enabled. (P_Index_Subtype_Def_With_Fixed_Lower_Bound): Support procedure for parsing unconstrained index ranges. (P_Index_Or_Discriminant_Constraint): Add handling for parsing of index constraints that specify ranges with fixed lower bounds. Report an error if such an index is encountered and GNAT language extensions are not enabled. * sem_ch3.adb (Analyze_Object_Declaration): If the object's nominal subtype is an array subtype with fixed lower bound, then Expand_Sliding_Conversion is applied to the object. (Array_Type_Declaration): Mark the array type and the subtypes of any indexes that specify a fixed lower bound as being fixed-lower-bound subtypes, and set the High_bound of the range of such an index to the upper bound of the named subtype. (Constrain_Array): For an array subtype with one or more index ranges specifying a fixed lower bound, set Is_Constrained to False and set the array subtype's Is_Fixed_Lower_Bound_Array_Subtype flag to True. (Constrain_Index): Mark the subtypes of an index that specifies a fixed lower bound as being a fixed-lower-bound index subtype, and set the High_bound of the range of such an index to the upper bound of the base type of the array type's corresponding index. * sem_res.adb (Resolve_Actuals): If a formal is of an unconstrained array subtype with fixed lower bound, then Expand_Sliding_Conversion is applied to the actual. * sem_util.adb (Build_Actual_Subtype): If the actual subtype corresponds to an unconstrained array subtype having any indexes with fixed lower bounds, then set the lower bounds of any such indexes of the actual subtype to the appropriate fixed lower bound of the formal subtype (rather than taking it from the formal itself). * sprint.adb (Sprint_Node_Actual, case N_Range): If a range's Etype has a fixed lower bound, then print "<>" rather than the High_Bound of the range. --- gcc/ada/checks.adb | 55 ++++++++-- gcc/ada/einfo.ads | 10 ++ gcc/ada/exp_ch4.adb | 7 ++ gcc/ada/exp_ch6.adb | 7 ++ gcc/ada/exp_util.adb | 181 +++++++++++++++++++++++++++++++ gcc/ada/exp_util.ads | 6 ++ gcc/ada/gen_il-fields.ads | 2 + gcc/ada/gen_il-gen-gen_entities.adb | 2 + gcc/ada/par-ch3.adb | 207 +++++++++++++++++++++++++++++++++++- gcc/ada/sem_ch3.adb | 90 +++++++++++++++- gcc/ada/sem_res.adb | 7 ++ gcc/ada/sem_util.adb | 30 ++++-- 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 " .. <>"). + +-- 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 " .. <>"). + -- 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 .. <> + -- 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: + -- range <> + -- or + -- range .. <> + -- + -- 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 .. <>") + + 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 + -- (" .. <>"), 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: + -- range <> + -- or + -- range .. <> + -- + -- 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: + -- range .. <>" + + 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 => -- 2.7.4