public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r12-1596] [Ada] Implementation of Inox feature of fixed lower bounds on array types/subtypes
@ 2021-06-17 14:35 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2021-06-17 14:35 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:d32db3a763249a8b94c2e2e285fc6f400eadea4e
commit r12-1596-gd32db3a763249a8b94c2e2e285fc6f400eadea4e
Author: Gary Dismukes <dismukes@adacore.com>
Date: Fri Mar 5 02:20:09 2021 -0500
[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.
Diff:
---
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 b46526ea2d6..8c4667cb431 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 fe9bf72898a..55cf83d847e 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 4436557b354..1d04a0613ca 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 b5d77bdcf7c..6314b0ae7a9 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 71052c003f7..19b8c656e2c 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 85e5a55aad5..2b3147d89d3 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 91a610addad..4aac802819a 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 85eb2d70817..afd3ec47696 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 2a7959939d0..52e52dcac8e 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 8d25a97fb0a..6720d41c221 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 32e71cc24f9..720f170ff73 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 47b6a93e150..d0e3b1a47c3 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 2eeea52d8bd..5f2d027dfaf 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 =>
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2021-06-17 14:35 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-06-17 14:35 [gcc r12-1596] [Ada] Implementation of Inox feature of fixed lower bounds on array types/subtypes Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).