einfo.ads, einfo.adb (First_Tag_Component): Protect the frontend against errors…

einfo.ads, einfo.adb (First_Tag_Component): Protect the frontend against errors in the source program...

2006-02-13  Javier Miranda  <miranda@adacore.com>
	    Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* einfo.ads, einfo.adb (First_Tag_Component): Protect the frontend
	against errors in the source program: a private types for which the
	corresponding full type declaration is missing and pragma CPP_Virtual
	is used.
	(Is_Unchecked_Union): Check flag on Implementation_Base_Type.
	(Is_Known_Null): New flag
	(Has_Pragma_Pure): New flag
	(No_Return): Present in all entities, set only for procedures
	(Is_Limited_Type): A type whose ancestor is an interface is limited if
	explicitly declared limited.
	(DT_Offset_To_Top_Func): New attribute that is present in E_Component
	entities. Only used for component marked Is_Tag. If present it stores
	the Offset_To_Top function used to provide this value in tagged types
	whose ancestor has discriminants.

	* exp_ch2.adb: Update status of new Is_Known_Null flag

	* sem_ch7.adb: Maintain status of new Is_Known_Null flag

	* sem_cat.adb (Get_Categorization): Don't treat function as Pure in
	the categorization sense if Is_Pure was set by pragma Pure_Function.

From-SVN: r111055

gcc/ada/einfo.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -209,6 +209,7 @@ package body Einfo is
    --    Privals_Chain                   Elist23
    --    Protected_Operation             Node23
 
+   --    DT_Offset_To_Top_Func           Node24
    --    Obsolescent_Warning             Node24
    --    Task_Body_Procedure             Node24
    --    Abstract_Interfaces             Elist24
@@ -453,9 +454,9 @@ package body Einfo is
 
    --    Has_Anon_Block_Suffix          Flag201
    --    Itype_Printed                  Flag202
+   --    Has_Pragma_Pure                Flag203
+   --    Is_Known_Null                  Flag204
 
-   --    (unused)                       Flag203
-   --    (unused)                       Flag204
    --    (unused)                       Flag205
    --    (unused)                       Flag206
    --    (unused)                       Flag207
@@ -832,6 +833,12 @@ package body Einfo is
       return Uint15 (Id);
    end DT_Entry_Count;
 
+   function DT_Offset_To_Top_Func (Id : E) return E is
+   begin
+      pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id));
+      return Node24 (Id);
+   end DT_Offset_To_Top_Func;
+
    function DT_Position (Id : E) return U is
    begin
       pragma Assert
@@ -1256,9 +1263,13 @@ package body Einfo is
       return Flag121 (Implementation_Base_Type (Id));
    end Has_Pragma_Pack;
 
+   function Has_Pragma_Pure (Id : E) return B is
+   begin
+      return Flag203 (Id);
+   end Has_Pragma_Pure;
+
    function Has_Pragma_Pure_Function (Id : E) return B is
    begin
-      pragma Assert (Is_Subprogram (Id));
       return Flag179 (Id);
    end Has_Pragma_Pure_Function;
 
@@ -1666,6 +1677,11 @@ package body Einfo is
       return Flag37 (Id);
    end Is_Known_Non_Null;
 
+   function Is_Known_Null (Id : E) return B is
+   begin
+      return Flag204 (Id);
+   end Is_Known_Null;
+
    function Is_Known_Valid (Id : E) return B is
    begin
       return Flag170 (Id);
@@ -1848,7 +1864,7 @@ package body Einfo is
 
    function Is_Unchecked_Union (Id : E) return B is
    begin
-      return Flag117 (Id);
+      return Flag117 (Implementation_Base_Type (Id));
    end Is_Unchecked_Union;
 
    function Is_Unsigned_Type (Id : E) return B is
@@ -1995,10 +2011,6 @@ package body Einfo is
 
    function No_Return (Id : E) return B is
    begin
-      pragma Assert
-        (Id = Any_Id
-          or else Ekind (Id) = E_Procedure
-          or else Ekind (Id) = E_Generic_Procedure);
       return Flag113 (Id);
    end No_Return;
 
@@ -2931,6 +2943,12 @@ package body Einfo is
       Set_Uint15 (Id, V);
    end Set_DT_Entry_Count;
 
+   procedure Set_DT_Offset_To_Top_Func (Id : E; V : E) is
+   begin
+      pragma Assert (Ekind (Id) = E_Component and then Is_Tag (Id));
+      Set_Node24 (Id, V);
+   end Set_DT_Offset_To_Top_Func;
+
    procedure Set_DT_Position (Id : E; V : U) is
    begin
       pragma Assert (Ekind (Id) = E_Function or else Ekind (Id) = E_Procedure);
@@ -3362,9 +3380,13 @@ package body Einfo is
       Set_Flag121 (Id, V);
    end Set_Has_Pragma_Pack;
 
+   procedure Set_Has_Pragma_Pure (Id : E; V : B := True) is
+   begin
+      Set_Flag203 (Id, V);
+   end Set_Has_Pragma_Pure;
+
    procedure Set_Has_Pragma_Pure_Function (Id : E; V : B := True) is
    begin
-      pragma Assert (Is_Subprogram (Id));
       Set_Flag179 (Id, V);
    end Set_Has_Pragma_Pure_Function;
 
@@ -3799,6 +3821,11 @@ package body Einfo is
       Set_Flag37 (Id, V);
    end Set_Is_Known_Non_Null;
 
+   procedure Set_Is_Known_Null (Id : E; V : B := True) is
+   begin
+      Set_Flag204 (Id, V);
+   end Set_Is_Known_Null;
+
    procedure Set_Is_Known_Valid (Id : E; V : B := True) is
    begin
       Set_Flag170 (Id, V);
@@ -4134,7 +4161,9 @@ package body Einfo is
    procedure Set_No_Return (Id : E; V : B := True) is
    begin
       pragma Assert
-        (Ekind (Id) = E_Procedure or else Ekind (Id) = E_Generic_Procedure);
+        (V = False
+          or else Ekind (Id) = E_Procedure
+          or else Ekind (Id) = E_Generic_Procedure);
       Set_Flag113 (Id, V);
    end Set_No_Return;
 
@@ -5749,6 +5778,16 @@ package body Einfo is
       elsif Is_Concurrent_Type (Btype) then
          return True;
 
+         --  The Is_Limited_Record flag normally indicates that the type is
+         --  limited. The exception is that a type does not inherit limitedness
+         --  from its interface ancestor. So the type may be derived from a
+         --  limited interface, but is not limited.
+
+      elsif Is_Limited_Record (Id)
+        and then not Is_Interface (Id)
+      then
+         return True;
+
       --  Otherwise we will look around to see if there is some other reason
       --  for it to be limited, except that if an error was posted on the
       --  entity, then just assume it is non-limited, because it can cause
@@ -5967,7 +6006,7 @@ package body Einfo is
 
       loop
          D := Next_Entity (D);
-         if not Present (D)
+         if No (D)
            or else (Ekind (D) /= E_Discriminant
                       and then not Is_Itype (D))
          then
@@ -6382,6 +6421,14 @@ package body Einfo is
 
       if Is_Private_Type (Typ) then
          Typ := Underlying_Type (Typ);
+
+         --  If the underlying type is missing then the source program has
+         --  errors and there is nothing else to do (the full-type declaration
+         --  associated with the private type declaration is missing).
+
+         if No (Typ) then
+            return Empty;
+         end if;
       end if;
 
       Comp := First_Entity (Typ);
@@ -6613,6 +6660,7 @@ package body Einfo is
       W ("Has_Pragma_Elaborate_Body",     Flag150 (Id));
       W ("Has_Pragma_Inline",             Flag157 (Id));
       W ("Has_Pragma_Pack",               Flag121 (Id));
+      W ("Has_Pragma_Pure",               Flag203 (Id));
       W ("Has_Pragma_Pure_Function",      Flag179 (Id));
       W ("Has_Pragma_Unreferenced",       Flag180 (Id));
       W ("Has_Primitive_Operations",      Flag120 (Id));
@@ -6684,7 +6732,8 @@ package body Einfo is
       W ("Is_Interrupt_Handler",          Flag89  (Id));
       W ("Is_Intrinsic_Subprogram",       Flag64  (Id));
       W ("Is_Itype",                      Flag91  (Id));
-      W ("Is_Known_Valid",                Flag37  (Id));
+      W ("Is_Known_Non_Null",             Flag37  (Id));
+      W ("Is_Known_Null",                 Flag204 (Id));
       W ("Is_Known_Valid",                Flag170 (Id));
       W ("Is_Limited_Composite",          Flag106 (Id));
       W ("Is_Limited_Interface",          Flag197 (Id));
@@ -7638,6 +7687,9 @@ package body Einfo is
               E_Record_Subtype_With_Private              =>
             Write_Str ("Abstract_Interfaces");
 
+         when E_Component                                =>
+            Write_Str ("DT_Offset_To_Top_Func");
+
          when Subprogram_Kind                            |
               E_Package                                  |
               E_Generic_Package                          =>

gcc/ada/sem_cat.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -145,14 +145,24 @@ package body Sem_Cat is
       begin
          if Is_Preelaborated (E) then
             return Preelaborated;
-         elsif Is_Pure (E) then
+
+            --  Ignore Pure specification if set by pragma Pure_Function
+
+         elsif Is_Pure (E)
+           and then not
+             (Has_Pragma_Pure_Function (E) and not Has_Pragma_Pure (E))
+         then
             return Pure;
+
          elsif Is_Shared_Passive (E) then
             return Shared_Passive;
+
          elsif Is_Remote_Types (E) then
             return Remote_Types;
+
          elsif Is_Remote_Call_Interface (E) then
             return Remote_Call_Interface;
+
          else
             return Normal;
          end if;
@@ -967,7 +977,7 @@ package body Sem_Cat is
       --  on instantiations).
 
       if Inside_A_Generic
-        and then not Present (Enclosing_Generic_Body (Id))
+        and then No (Enclosing_Generic_Body (Id))
       then
          return;
       end if;

gcc/ada/sem_ch7.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -746,7 +746,11 @@ package body Sem_Ch7 is
                Set_Never_Set_In_Source (E, False);
                Set_Is_True_Constant    (E, False);
                Set_Current_Value       (E, Empty);
-               Set_Is_Known_Non_Null   (E, False);
+               Set_Is_Known_Null       (E, False);
+
+               if not Can_Never_Be_Null (E) then
+                  Set_Is_Known_Non_Null (E, False);
+               end if;
 
             elsif Ekind (E) = E_Package
                     or else