mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-03 08:50:31 +08:00
Code Issues Packages Projects Releases Wiki Activity

[Ada] Spurious error on dependent expression that is an array

Browse Source 
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
This commit is contained in:
Ed Schonberg 2018-12-03 15:49:50 +00:00 committed by Pierre-Marie de Rodat
parent 2e8f791932
commit cddd902d35
4 changed files with 110 additions and 6 deletions

7
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

20
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),

4
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.

85
gcc/testsuite/gnat.dg/array33.adb Normal file

@ -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;