This patch fixes a compiler abort on an object declaration for a private
type with discriminants, when the full view of the type is derived from
an ancestor with additional discriminants and the derivation chain includes
discriminant renamings.
Executing
gnatmake -q main
main
must yield:
13
---
with Types; use Types;
with Text_IO; use Text_IO;
procedure Main is
Obj : Deriv_13 (13);
begin
Put_Line (Integer'Image (Obj.D_1));
end Main;
---
package Types is
type Par_13 (D_1 : Integer; D_2 : Integer) is tagged private;
type Mid_13 (D_3 : Integer) is new Par_13 with private;
type Deriv_13 (D_1 : Integer) is tagged private;
private
type Par_13 (D_1 : Integer; D_2 : Integer) is tagged null record;
type Mid_13 (D_3 : Integer) is
new Par_13 (D_1 => 123, D_2 => D_3) with null record;
type Deriv_13 (D_1 : Integer) is new Mid_13 (D_3 => D_1) with null record;
end Types;
Tested on x86_64-pc-linux-gnu, committed on trunk
2017-04-25 Ed Schonberg <schonb...@adacore.com>
* sem_ch3.adb (Get_Discriminant_Value, Search_Derivation_Levels):
Handle properly a multi- level derivation involving both renamed
and constrained parent discriminants, when the type to be
constrained has fewer discriminants that the ultimate ancestor.
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb (revision 247135)
+++ sem_ch3.adb (working copy)
@@ -17660,8 +17660,13 @@
end if;
while Present (Disc) loop
- pragma Assert (Present (Assoc));
+ -- If no further associations return the discriminant, value
+ -- will be found on the second pass.
+ if No (Assoc) then
+ return Result;
+ end if;
+
if Original_Record_Component (Disc) = Result_Entity then
return Node (Assoc);
end if;
@@ -17690,6 +17695,8 @@
-- ??? This routine is a gigantic mess and will be deleted. For the
-- time being just test for the trivial case before calling recurse.
+ -- We are now celebrating the 20th anniversary of this comment!
+
if Base_Type (Scope (Discriminant)) = Base_Type (Typ_For_Constraint) then
declare
D : Entity_Id;
