[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  <schonberg@adacore.com>

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

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 0736bb38f9d0c26255cdc96fdf0401975f737018..15b5bcffc7ae141593ad9b1aac0d5b59f3846737 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2018-12-03  Ed Schonberg  <schonberg@adacore.com>
+
+       * 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  <kirtchev@adacore.com>
 
        * 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 ad0b5a06abc01c8c8bc64bf6dffdbb4f4f3ae4bc..ab26fbefb509c781a4270e32bb7fff5e4eb46cf4 100644 (file)
--- 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 110932fdbbb65579cf4d372407b75c9d70f319b4..e2b84554e30f5914fc4759e2cea4714a02872390 100644 (file)
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2018-12-03  Ed Schonberg  <schonberg@adacore.com>
+
+       * gnat.dg/array33.adb: New testcase.
+
 2018-12-03  Eric Botcazou  <ebotcazou@adacore.com>
 
        * 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 (file)
index 0000000..3e14674
--- /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;