Patchwork [Ada] Untagged incomplete views completed with tagged types

login
register
mail settings
Submitter Arnaud Charlet
Date June 17, 2010, 1:25 p.m.
Message ID <20100617132503.GA13620@adacore.com>
Download mbox | patch
Permalink /patch/56045/
State New
Headers show

Comments

Arnaud Charlet - June 17, 2010, 1:25 p.m.
If an untagged incomplete type is completed with an extension, the class_wide
type must be created for the full view. If the full view has self-referential
components of an anonymous access type, the class_wide type must be created
before the component declarations are analyzed.

Compiling the following program must yield the following warning:

   crash.ads:3:04: warning: imcomplete view of tagged type should be tagged

package Crash is
   type R;
   type T;   --   should be tagged;

   type R is tagged null record;

   type T_A is access all T;

   type T is new R with record
      Self : access T'Class;
   end record;

   function F return access T'Class;
end Crash;
---
package body Crash is
   function F return access T'Class is
      V : constant T_A := new T;
   begin
      if True then
         V.Self := F;
      end if;

      return V;
   end F;
end Crash;

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

2010-06-17  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch3.adb (Build_Incomplete_Type_Declaration): If there is an
	incomplete view of the type that is not tagged, and the full type is a
	tagged extension, create class_wide type now, and warn that the
	incomplete view should be tagged as well.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 160897)
+++ sem_ch3.adb	(working copy)
@@ -17484,6 +17484,15 @@  package body Sem_Ch3 is
            and then Ekind (Current_Entity (Typ)) = E_Incomplete_Type
            and then Full_View (Current_Entity (Typ)) = Typ
          then
+            if Is_Tagged
+              and then Comes_From_Source (Current_Entity (Typ))
+              and then not Is_Tagged_Type (Current_Entity (Typ))
+            then
+               Make_Class_Wide_Type (Typ);
+               Error_Msg_N
+                 ("incomplete view of tagged type should be declared tagged?",
+                    Parent (Current_Entity (Typ)));
+            end if;
             return;
 
          else