From cddd902d35bfef2bf6cea89b63d6dea23e0babed Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Mon, 3 Dec 2018 15:49:50 +0000 Subject: [PATCH] [Ada] Spurious error on dependent expression that is an array This patch fixes a spurious error on a array expression that is a dependent expression of an if-expression, when the length of the array matches that imposed by the context, but the bounds of both differ, in particular when the expression and the context are both null arrays with different bounds. 2018-12-03 Ed Schonberg gcc/ada/ * sem_res.adb (Apply_Check): For array types, apply a length check rather than a qualification, to avoid spurious errors when the value of a dependend expression has a matching length but different bounds from those of the type of the contect. gcc/testsuite/ * gnat.dg/array33.adb: New testcase. From-SVN: r266758 --- gcc/ada/ChangeLog | 7 +++ gcc/ada/sem_res.adb | 20 +++++--- gcc/testsuite/ChangeLog | 4 ++ gcc/testsuite/gnat.dg/array33.adb | 85 +++++++++++++++++++++++++++++++ 4 files changed, 110 insertions(+), 6 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/array33.adb diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0736bb38f9d..15b5bcffc7a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2018-12-03 Ed Schonberg + + * sem_res.adb (Apply_Check): For array types, apply a length + check rather than a qualification, to avoid spurious errors when + the value of a dependend expression has a matching length but + different bounds from those of the type of the contect. + 2018-12-03 Hristian Kirtchev * libgnat/a-calend.adb: Update the number of leap seconds. Add diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index ad0b5a06abc..ab26fbefb50 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -8461,7 +8461,9 @@ package body Sem_Res is -- When a dependent expression is of a subtype different from -- the context subtype, then insert a qualification to ensure -- the generation of a constraint check. This was previously - -- done only for scalar types. + -- for scalar types. For array types apply a length check, given + -- that the context in general allows sliding, while a qualified + -- expression forces equality of bounds. ----------------- -- Apply_Check -- @@ -8472,12 +8474,18 @@ package body Sem_Res is Loc : constant Source_Ptr := Sloc (Expr); begin - if Expr_Typ /= Typ - and then not Is_Tagged_Type (Typ) - and then not Is_Access_Type (Typ) - and then Is_Constrained (Typ) - and then not Inside_A_Generic + if Expr_Typ = Typ + or else Is_Tagged_Type (Typ) + or else Is_Access_Type (Typ) + or else not Is_Constrained (Typ) + or else Inside_A_Generic then + null; + + elsif Is_Array_Type (Typ) then + Apply_Length_Check (Expr, Typ); + + else Rewrite (Expr, Make_Qualified_Expression (Loc, Subtype_Mark => New_Occurrence_Of (Typ, Loc), diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 110932fdbbb..e2b84554e30 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-12-03 Ed Schonberg + + * gnat.dg/array33.adb: New testcase. + 2018-12-03 Eric Botcazou * gnat.dg/array32.adb, gnat.dg/array32.ads: New testcase. diff --git a/gcc/testsuite/gnat.dg/array33.adb b/gcc/testsuite/gnat.dg/array33.adb new file mode 100644 index 00000000000..3e146748f21 --- /dev/null +++ b/gcc/testsuite/gnat.dg/array33.adb @@ -0,0 +1,85 @@ +-- { dg-do run } + +procedure Array33 is + generic + type Item_T is private; -- The type of which the interval is made of. + type Bound_T is private; + None_Bound : Bound_T; + Bounds_Are_Static : Boolean := False; + type Value_T is private; + type Base_Index_T is range <>; + package General_Interval_Partition_G is + subtype Length_T is Base_Index_T range 0 .. Base_Index_T'Last; + subtype Index_T is Base_Index_T range 1 .. Base_Index_T'Last; + type T is private; + function Single (First, Last : Bound_T; Value : Value_T) return T; + function Single1 (First, Last : Bound_T; Value : Value_T) return T; + private + type Bounds_Array_T is array (Length_T range <>) of Bound_T; + type Values_Array_T is array (Index_T range <>) of Value_T; + + First_Bounds_Index : constant Length_T + := 2 * Boolean'Pos (Bounds_Are_Static); + -- See below explanation on indexing the bounds. + + + type Obj_T (Length : Length_T) is + record + Bounds : Bounds_Array_T (First_Bounds_Index .. Length) + := (others => None_Bound); + -- This is tricky. If Bounds_Are_Static is true, the array does not + -- store the lower or upper bound. + -- This lowers memory requirements for the data structure at the cost + -- of slightly more complex indexing. + -- + -- Bounds as seen internally depending on the parameter: + -- + -- Bounds_Are_Static | Lower_Bound | Inbetween Bounds (if any) | Upper_Bound + -- True => Max_First & Bounds (2 .. Length) & Min_Last + -- False => Bounds (0) & Bounds (1 .. Length - 1) & Bounds (Length) + -- + Values : Values_Array_T (1 .. Length); + end record; + + type T is access Obj_T; + --@@ if ccf:defined(debug_pool) then + --@@! for T'Storage_Pool use Pool_Selection_T'Storage_Pool; + --@@ end if + + end General_Interval_Partition_G; + + package body General_Interval_Partition_G is + + function Single (First, Last : Bound_T; Value : Value_T) return T is + begin + return new Obj_T'(Length => 1, + Bounds => (if Bounds_Are_Static + then (2 .. 0 => None_Bound) + -- Now raises constraint error here + else (0 => First, 1 => Last)), + Values => (1 => Value)); + end Single; + function Single1 (First, Last : Bound_T; Value : Value_T) return T is + begin + return new Obj_T'( 1, + (if Bounds_Are_Static + then (2 .. 0 => None_Bound) + -- Now raises constraint error here + else (0 => First, 1 => Last)), + (1 => Value)); + end Single1; + end General_Interval_Partition_G; + + type T is new Integer; + + package Partition is new General_Interval_Partition_G (Item_T => T, + Bound_T => T, + None_Bound => 0, + Bounds_Are_Static => True, + Value_T => T, + Base_Index_T => Natural); + X : constant Partition.T := Partition.Single (1,1,1); + Z : constant Partition.T := Partition.Single1 (1,1,1); +begin + null; +end; -- 2.30.2