This patch removes a spurious discriminant check on an generated assignment
statement in an iterator loop, when the cursor type is a type with unknown
discriminants, when the full view has discriminants with defaults.
Executing:
gnatmake -f -q -g date_iteration_test.adb
date_iteration_test
Must yield:
1
2
3
4
5
6
7
8
9
10
2015-12-31 05:00:00
2016-01-01 05:00:00
2016-01-02 05:00:00
2016-01-03 05:00:00
2016-01-04 05:00:00
2016-01-05 05:00:00
2016-01-06 05:00:00
2016-01-07 05:00:00
2016-01-08 05:00:00
2016-01-09 05:00:00
2016-01-10 05:00:00
---
with Date_Iteration;
with Ada.Calendar.Formatting;
with Ada.Text_IO; use Ada.Text_IO;
procedure Date_Iteration_Test is
use type Ada.Calendar.Time;
Day : constant Duration := 86_400.0;
Number : Natural := 0;
begin
for D in Date_Iteration.Generator
(Start_Time => Ada.Calendar.Clock,
End_Time => Ada.Calendar.Clock + Day * 10)
loop
Number := Number + 1;
Put_Line (Number'Img);
end loop;
New_Line;
for D of Date_Iteration.Generator
(Start_Time => Ada.Calendar.Time_Of (2015, 12, 31),
End_Time => Ada.Calendar.Time_Of (2015, 12, 31) + Day * 10)
loop
Put_Line (Ada.Calendar.Formatting.Image (D));
end loop;
end Date_Iteration_Test;
---
with Ada.Calendar;
with Ada.Iterator_Interfaces;
package Date_Iteration is
type Cursor (<>) is private;
function Has_Element (C : Cursor) return Boolean;
function Date (C : Cursor) return Ada.Calendar.Time;
package Iterator_Interfaces
is new Ada.Iterator_Interfaces (Cursor, Has_Element);
type Date_Set is new Iterator_Interfaces.Forward_Iterator with private
with
Constant_Indexing => Element,
Default_Iterator => Iterate,
Iterator_Element => Ada.Calendar.Time;
function Element (Set : Date_Set; C : Cursor) return Ada.Calendar.Time;
function Iterate (Set : Date_Set)
return Iterator_Interfaces.Forward_Iterator'Class;
function Generator (Start_Time : Ada.Calendar.Time;
End_Time : Ada.Calendar.Time;
Interval : Duration := 86_400.0)
return Date_Set;
private
type Cursor (Valid : Boolean := True) is record
case Valid is
when True =>
Date : Ada.Calendar.Time;
when False =>
null;
end case;
end record;
function Has_Element (C : Cursor) return Boolean is (C.Valid);
function Date (C : Cursor) return Ada.Calendar.Time is (C.Date);
type Date_Set is new Iterator_Interfaces.Forward_Iterator with record
Start_Time : Ada.Calendar.Time;
End_Time : Ada.Calendar.Time;
Interval : Duration;
end record;
overriding
function First (Object : Date_Set) return Cursor;
overriding
function Next (Object : Date_Set; Position : Cursor) return Cursor;
function Element (Set : Date_Set; C : Cursor) return Ada.Calendar.Time
is (C.Date);
function Iterate (Set : Date_Set)
return Iterator_Interfaces.Forward_Iterator'Class
is (Set);
end Date_Iteration;
---
package body Date_Iteration is
function Generator (Start_Time : Ada.Calendar.Time;
End_Time : Ada.Calendar.Time;
Interval : Duration := 86_400.0)
return Date_Set is
begin
return D : Date_Set do
D := (Start_Time => Start_Time,
End_Time => End_Time,
Interval => Interval);
end return;
end Generator;
function First (Object : Date_Set) return Cursor is
use type Ada.Calendar.Time;
begin
if Object.End_Time >= Object.Start_Time then
return (Valid => True, Date => Object.Start_Time);
else
return (Valid => False);
end if;
end First;
function Next (Object : Date_Set; Position : Cursor)
return Cursor is
use type Ada.Calendar.Time;
Next : Ada.Calendar.Time := Position.Date + Object.Interval;
begin
if Next > Object.End_Time then
return (Valid => False);
else
return (Valid => True, Date => Next);
end if;
end Next;
end Date_Iteration;
Tested on x86_64-pc-linux-gnu, committed on trunk
2016-04-20 Ed Schonberg <schonb...@adacore.com>
* exp_ch5.adb (Expand_N_Assignment_Statement): Do no generate
a discriminant check for a type whose partial view has unknown
discriminants when the full view has discriminants with defaults.
Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb (revision 235265)
+++ exp_ch5.adb (working copy)
@@ -1946,10 +1946,12 @@
-- have a full view with discriminants, but those are nameable only
-- in the underlying type, so convert the Rhs to it before potential
-- checking. Convert Lhs as well, otherwise the actual subtype might
- -- not be constructible.
+ -- not be constructible. If the discriminants have defaults the type
+ -- is unconstrained and there is nothing to check.
elsif Has_Unknown_Discriminants (Base_Type (Etype (Lhs)))
and then Has_Discriminants (Typ)
+ and then not Has_Defaulted_Discriminants (Typ)
then
Rewrite (Rhs, OK_Convert_To (Base_Type (Typ), Rhs));
Rewrite (Lhs, OK_Convert_To (Base_Type (Typ), Lhs));
