Patchwork [Ada] Crash on derivation of tagged private type with discriminants

login
register
mail settings
Submitter Arnaud Charlet
Date June 22, 2010, 10:07 a.m.
Message ID <20100622100718.GA10417@adacore.com>
Download mbox | patch
Permalink /patch/56448/
State New
Headers show

Comments

Arnaud Charlet - June 22, 2010, 10:07 a.m.
A record extension always freezes its parent type. However this freezing
was erroneously omitted in the case of a tagged private ancestor with
discriminants, causing a compiler crash while freezing the derived type.

This change adds the missing freeze operation. The following compilation
must be accepted cleanly:

$ gcc -c derived_from_pvt_disc2.ads
package Derived_From_Pvt_Disc2 is
   package P1 is
      type T1 (X : Integer) is tagged private;
   private
      type T1 (X : Integer) is tagged null record;
   end P1;
   type T2 is new P1.T1 (1) with null record;
end Derived_From_Pvt_Disc2;

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-06-22  Thomas Quinot  <quinot@adacore.com>

	* sem_ch3.adb (Build_Derived_Record_Type): When deriving a tagged
	private type with discriminants, make sure the parent type is frozen.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 161159)
+++ sem_ch3.adb	(working copy)
@@ -6790,6 +6790,13 @@  package body Sem_Ch3 is
          Mark_Rewrite_Insertion (New_Decl);
          Insert_Before (N, New_Decl);
 
+         --  In the tagged case, make sure ancestor is frozen appropriately
+         --  (see also non-discriminated case below).
+
+         if not Private_Extension or else Is_Interface (Parent_Base) then
+            Freeze_Before (New_Decl, Parent_Type);
+         end if;
+
          --  Note that this call passes False for the Derive_Subps parameter
          --  because subprogram derivation is deferred until after creating
          --  the subtype (see below).
@@ -6880,9 +6887,7 @@  package body Sem_Ch3 is
          --  The declaration of a specific descendant of an interface type
          --  freezes the interface type (RM 13.14).
 
-         if not Private_Extension
-           or else Is_Interface (Parent_Base)
-         then
+         if not Private_Extension or else Is_Interface (Parent_Base) then
             Freeze_Before (N, Parent_Type);
          end if;