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.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@111055 138bc75d-0d04-0410-961f-82ee72b054a4

5 files changed, 217 insertions, 176 deletions

diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 4a9eb8b8881..c9361f152c3 100644
--- a/gcc/ada/einfo.adb
+++ b/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                          =>
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 290fd44c15d..b8a4c461ed2 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          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- --
@@ -361,7 +361,7 @@ package Einfo is
 --       back-end for back annotation.
 
 --    Alignment_Clause (synthesized)
---       Appllies to all entities for types and objects. If an alignment
+--       Applies to all entities for types and objects. If an alignment
 --       attribute definition clause is present for the entity, then this
 --       function returns the N_Attribute_Definition clause that specifies the
 --       alignment. If no alignment clause applies to the type, then the call
@@ -384,7 +384,13 @@ package Einfo is
 --       Present in all type and subtype entities. Set non-Empty only for
 --       Itypes. Set to point to the associated node for the Itype, i.e.
 --       the node whose elaboration generated the Itype. This is used for
---       copying trees, to determine whether or not to copy an Itype.
+--       copying trees, to determine whether or not to copy an Itype, and
+--       also for accessibility checks on anonymous access types. This
+--       node is typically an object declaration, component declaration,
+--       type or subtype declaration. For an access discriminant in a type
+--       declaration, the associated_node_for_itype is the discriminant
+--       specification. For an access parameter it is the enclosing subprogram
+--       declaration.
 
 --    Associated_Storage_Pool (Node22) [root type only]
 --       Present in simple and general access type entities. References the
@@ -796,6 +802,11 @@ package Einfo is
 --       Present in E_Component entities. Only used for component marked
 --       Is_Tag. Store the number of entries in the Vtable (or Dispatch Table)
 
+--    DT_Offset_To_Top_Func (Node24)
+--       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.
+
 --    DT_Position (Uint15)
 --       Present in function and procedure entities which are dispatching
 --       (should not be referenced without first checking that flag
@@ -1142,7 +1153,7 @@ package Einfo is
 --       as First_Discriminant.
 --
 --       For derived non-tagged types that rename discriminants in the root
---       type this is the first of the discriminants that occurr in the
+--       type this is the first of the discriminants that occur in the
 --       root type. To be precise, in this case stored discriminants are
 --       entities attached to the entity chain of the derived type which
 --       are a copy of the discriminants of the root type. Furthermore their
@@ -1159,6 +1170,10 @@ package Einfo is
 --       subtype of the type. For subtypes, yields the first subtype of
 --       the base type of the subtype.
 
+--    First_Tag_Component (synthesized)
+--       Applies to tagged record types, returns the entity for the first
+--       _Tag field in this record.
+
 --    Freeze_Node (Node7)
 --       Present in all entities. If there is an associated freeze node for
 --       the entity, this field references this freeze node. If no freeze
@@ -1465,12 +1480,17 @@ package Einfo is
 --       for the entity.
 
 --    Has_Pragma_Pack (Flag121) [implementation base type only]
---       Present in all entities. It indicates that a valid pragma Pack was
---       was given for the type. Note that this flag is not inherited by a
+--       Present in all entities. If set, indicates that a valid pragma Pack
+--       was was given for the type. Note that this flag is not inherited by
 --       derived type. See also the Is_Packed flag.
 
+--    Has_Pragma_Pure (Flag203)
+--       Present in all entities. If set, indicates that a valid pragma Pure
+--       was given for the entity. In some cases, we need to test whether
+--       Is_Pure was explicitly set using this pragma.
+
 --    Has_Pragma_Pure_Function (Flag179)
---       Present in subprogram entities. It indicates that a valid pragma
+--       Present in all entities. If set, indicates that a valid pragma
 --       Pure_Function was given for the entity. In some cases, we need to
 --       know that Is_Pure was explicitly set using this pragma.
 
@@ -2052,7 +2072,7 @@ package Einfo is
 --       objects of an access type. It is set if the object is currently
 --       known to have a non-null value (meaning that no access checks
 --       are needed). The indication can for example come from assignment
---       of an access parameter or an allocator.
+--       of an access parameter or an allocator whose value is known non-null.
 --
 --       Note: this flag is set according to the sequential flow of the
 --       program, watching the current value of the variable. However,
@@ -2068,6 +2088,16 @@ package Einfo is
 --       fully constructed, since it simply indicates the last state.
 --       Thus this flag has no meaning to the back end.
 
+--    Is_Known_Null (Flag204)
+--       Present in all entities. Relevant (and can be set True) only for
+--       objects of an access type. It is set if the object is currently known
+--       to have a null value (meaning that a dereference will surely raise
+--       constraint error exception). The indication can come from an
+--       assignment or object declaration.
+--
+--       The comments above about sequential flow and aliased and volatile for
+--       the Is_Known_Non_Null flag apply equally to the Is_Known_Null flag.
+
 --    Is_Known_Valid (Flag170)
 --       Present in all entities. Relevant for types (and subtype) and
 --       for objects (and enumeration literals) of a discrete type.
@@ -2419,7 +2449,7 @@ package Einfo is
 --    Is_Type (synthesized)
 --       Applies to all entities, true for a type entity
 
---    Is_Unchecked_Union (Flag117)
+--    Is_Unchecked_Union (Flag117) [implementation base type only]
 --       Present in all entities. Set only in record types to which the
 --       pragma Unchecked_Union has been validly applied.
 
@@ -2680,6 +2710,10 @@ package Einfo is
 --       Empty if applied to the last literal. This is actually a synonym
 --       for Next, but its use is preferred in this context.
 
+--    Next_Tag_Component (synthesized)
+--       Applies to components of tagged record types. Given a _Tag field
+--       of a record, returns the next _Tag field in this record.
+
 --    Non_Binary_Modulus (Flag58) [base type only]
 --       Present in modular integer types. Set if the modulus for the type
 --       is other than a power of 2.
@@ -2702,8 +2736,8 @@ package Einfo is
 --       type, since derived types must have the same pool.
 
 --    No_Return (Flag113)
---       Present in procedure and generic procedure entries. Indicates that
---       a pragma No_Return applies to the procedure.
+--       Present in all entities. Always false except in the case of procedures
+--       and generic procedures for which a pragma No_Return is given.
 
 --    Normalized_First_Bit (Uint8)
 --       Present in components and discriminants. Indicates the normalized
@@ -2985,7 +3019,7 @@ package Einfo is
 
 --    Returns_By_Ref (Flag90)
 --       Present in function entities, to indicate that the function
---       returns the result by reference, either because its return typ is a
+--       returns the result by reference, either because its return type is a
 --       by-reference-type or because it uses explicitly the secondary stack.
 
 --    Reverse_Bit_Order (Flag164) [base type only]
@@ -3033,7 +3067,9 @@ package Einfo is
 --       Present in all entities. Points to the entity for the scope (block,
 --       loop, subprogram, package etc.) in which the entity is declared.
 --       Since this field is in the base part of the entity node, the access
---       routines for this field are in Sinfo.
+--       routines for this field are in Sinfo. Note that for a child package,
+--       the Scope will be the parent package, and for a non-child package,
+--       the Scope will be Standard.
 
 --    Scope_Depth (synth)
 --       Applies to program units, blocks, concurrent types and entries,
@@ -3181,14 +3217,6 @@ package Einfo is
 --       bodies are expanded into procedures). A convenient function to
 --       retrieve this field is Sem_Util.Get_Task_Body_Procedure.
 
---    First_Tag_Component (synthesized)
---       Applies to tagged record types, returns the entity for the first
---       _Tag field in this record.
-
---    Next_Tag_Component (synthesized)
---       Applies to components of tagged record types. Given a _Tag field
---       of a record, returns the next _Tag field in this record.
-
 --    Treat_As_Volatile (Flag41)
 --       Present in all type entities, and also in constants, components and
 --       variables. Set if this entity is to be treated as volatile for code
@@ -4054,6 +4082,8 @@ package Einfo is
    --    Has_Persistent_BSS            (Flag188)
    --    Has_Pragma_Elaborate_Body     (Flag150)
    --    Has_Pragma_Inline             (Flag157)
+   --    Has_Pragma_Pure               (Flag203)
+   --    Has_Pragma_Pure_Function      (Flag179)
    --    Has_Pragma_Unreferenced       (Flag180)
    --    Has_Private_Declaration       (Flag155)
    --    Has_Qualified_Name            (Flag161)
@@ -4078,6 +4108,7 @@ package Einfo is
    --    Is_Internal                   (Flag17)
    --    Is_Itype                      (Flag91)
    --    Is_Known_Non_Null             (Flag37)
+   --    Is_Known_Null                 (Flag204)
    --    Is_Known_Valid                (Flag170)
    --    Is_Limited_Composite          (Flag106)
    --    Is_Limited_Record             (Flag25)
@@ -4100,6 +4131,7 @@ package Einfo is
    --    Kill_Tag_Checks               (Flag34)
    --    Materialize_Entity            (Flag168)
    --    Needs_Debug_Info              (Flag147)
+   --    No_Return                     (Flag113)
    --    Referenced                    (Flag156)
    --    Referenced_As_LHS             (Flag36)
    --    Suppress_Elaboration_Warnings (Flag148)
@@ -4296,6 +4328,7 @@ package Einfo is
    --    Interface_Name                (Node21)   (JGNAT usage only)
    --    Original_Record_Component     (Node22)
    --    Protected_Operation           (Node23)
+   --    DT_Offset_To_Top_Func         (Node24)
    --    Has_Biased_Representation     (Flag139)
    --    Has_Per_Object_Constraint     (Flag154)
    --    Is_Atomic                     (Flag85)
@@ -4474,7 +4507,6 @@ package Einfo is
    --    Has_Master_Entity             (Flag21)
    --    Has_Missing_Return            (Flag142)
    --    Has_Nested_Block_With_Handler (Flag101)
-   --    Has_Pragma_Pure_Function      (Flag179)  (non-generic case only)
    --    Has_Recursive_Call            (Flag143)
    --    Has_Subprogram_Descriptor     (Flag93)
    --    Is_Abstract                   (Flag19)
@@ -4604,7 +4636,6 @@ package Einfo is
    --    Is_Intrinsic_Subprogram       (Flag64)
    --    Is_Overriding_Operation       (Flag39)
    --    Default_Expressions_Processed (Flag108)
-   --    Has_Pragma_Pure_Function      (Flag179)
 
    --  E_Ordinary_Fixed_Point_Type
    --  E_Ordinary_Fixed_Point_Subtype
@@ -4712,7 +4743,6 @@ package Einfo is
    --    Abstract_Interface_Alias      (Node25)
    --    Overridden_Operation          (Node26)
    --    Wrapped_Entity                (Node27)   (non-generic case only)
-
    --    Body_Needed_For_SAL           (Flag40)
    --    Elaboration_Entity_Required   (Flag174)
    --    Function_Returns_With_DSP     (Flag169)  (always False for procedure)
@@ -4723,7 +4753,6 @@ package Einfo is
    --    Has_Completion                (Flag26)
    --    Has_Master_Entity             (Flag21)
    --    Has_Nested_Block_With_Handler (Flag101)
-   --    Has_Pragma_Pure_Function      (Flag179)  (non-generic case only)
    --    Has_Subprogram_Descriptor     (Flag93)
    --    Is_Visible_Child_Unit         (Flag116)
    --    Is_Abstract                   (Flag19)
@@ -4738,7 +4767,6 @@ package Einfo is
    --    Is_Null_Init_Proc             (Flag178)
    --    Is_Overriding_Operation       (Flag39)   (non-generic case only)
    --    Is_Primitive_Wrapper          (Flag195)  (non-generic case only)
-
    --    Is_Private_Descendant         (Flag53)
    --    Is_Pure                       (Flag44)
    --    Is_Thread_Body                (Flag77)   (non-generic case only)
@@ -5192,6 +5220,7 @@ package Einfo is
    function Debug_Renaming_Link                (Id : E) return E;
    function DTC_Entity                         (Id : E) return E;
    function DT_Entry_Count                     (Id : E) return U;
+   function DT_Offset_To_Top_Func              (Id : E) return E;
    function DT_Position                        (Id : E) return U;
    function Default_Expr_Function              (Id : E) return E;
    function Default_Expressions_Processed      (Id : E) return B;
@@ -5283,6 +5312,7 @@ package Einfo is
    function Has_Pragma_Elaborate_Body          (Id : E) return B;
    function Has_Pragma_Inline                  (Id : E) return B;
    function Has_Pragma_Pack                    (Id : E) return B;
+   function Has_Pragma_Pure                    (Id : E) return B;
    function Has_Pragma_Pure_Function           (Id : E) return B;
    function Has_Pragma_Unreferenced            (Id : E) return B;
    function Has_Primitive_Operations           (Id : E) return B;
@@ -5354,6 +5384,7 @@ package Einfo is
    function Is_Intrinsic_Subprogram            (Id : E) return B;
    function Is_Itype                           (Id : E) return B;
    function Is_Known_Non_Null                  (Id : E) return B;
+   function Is_Known_Null                      (Id : E) return B;
    function Is_Known_Valid                     (Id : E) return B;
    function Is_Limited_Composite               (Id : E) return B;
    function Is_Limited_Interface               (Id : E) return B;
@@ -5691,6 +5722,7 @@ package Einfo is
    procedure Set_Debug_Renaming_Link           (Id : E; V : E);
    procedure Set_DTC_Entity                    (Id : E; V : E);
    procedure Set_DT_Entry_Count                (Id : E; V : U);
+   procedure Set_DT_Offset_To_Top_Func         (Id : E; V : E);
    procedure Set_DT_Position                   (Id : E; V : U);
    procedure Set_Default_Expr_Function         (Id : E; V : E);
    procedure Set_Default_Expressions_Processed (Id : E; V : B := True);
@@ -5780,6 +5812,7 @@ package Einfo is
    procedure Set_Has_Pragma_Elaborate_Body     (Id : E; V : B := True);
    procedure Set_Has_Pragma_Inline             (Id : E; V : B := True);
    procedure Set_Has_Pragma_Pack               (Id : E; V : B := True);
+   procedure Set_Has_Pragma_Pure               (Id : E; V : B := True);
    procedure Set_Has_Pragma_Pure_Function      (Id : E; V : B := True);
    procedure Set_Has_Pragma_Unreferenced       (Id : E; V : B := True);
    procedure Set_Has_Primitive_Operations      (Id : E; V : B := True);
@@ -5856,6 +5889,7 @@ package Einfo is
    procedure Set_Is_Intrinsic_Subprogram       (Id : E; V : B := True);
    procedure Set_Is_Itype                      (Id : E; V : B := True);
    procedure Set_Is_Known_Non_Null             (Id : E; V : B := True);
+   procedure Set_Is_Known_Null                 (Id : E; V : B := True);
    procedure Set_Is_Known_Valid                (Id : E; V : B := True);
    procedure Set_Is_Limited_Composite          (Id : E; V : B := True);
    procedure Set_Is_Limited_Interface          (Id : E; V : B := True);
@@ -6244,6 +6278,7 @@ package Einfo is
    pragma Inline (Debug_Renaming_Link);
    pragma Inline (DTC_Entity);
    pragma Inline (DT_Entry_Count);
+   pragma Inline (DT_Offset_To_Top_Func);
    pragma Inline (DT_Position);
    pragma Inline (Default_Expr_Function);
    pragma Inline (Default_Expressions_Processed);
@@ -6333,6 +6368,7 @@ package Einfo is
    pragma Inline (Has_Pragma_Elaborate_Body);
    pragma Inline (Has_Pragma_Inline);
    pragma Inline (Has_Pragma_Pack);
+   pragma Inline (Has_Pragma_Pure);
    pragma Inline (Has_Pragma_Pure_Function);
    pragma Inline (Has_Pragma_Unreferenced);
    pragma Inline (Has_Primitive_Operations);
@@ -6429,6 +6465,7 @@ package Einfo is
    pragma Inline (Is_Intrinsic_Subprogram);
    pragma Inline (Is_Itype);
    pragma Inline (Is_Known_Non_Null);
+   pragma Inline (Is_Known_Null);
    pragma Inline (Is_Known_Valid);
    pragma Inline (Is_Limited_Composite);
    pragma Inline (Is_Limited_Interface);
@@ -6616,6 +6653,8 @@ package Einfo is
    pragma Inline (Set_Debug_Info_Off);
    pragma Inline (Set_Debug_Renaming_Link);
    pragma Inline (Set_DTC_Entity);
+   pragma Inline (Set_DT_Entry_Count);
+   pragma Inline (Set_DT_Offset_To_Top_Func);
    pragma Inline (Set_DT_Position);
    pragma Inline (Set_Default_Expr_Function);
    pragma Inline (Set_Default_Expressions_Processed);
@@ -6703,6 +6742,7 @@ package Einfo is
    pragma Inline (Set_Has_Pragma_Elaborate_Body);
    pragma Inline (Set_Has_Pragma_Inline);
    pragma Inline (Set_Has_Pragma_Pack);
+   pragma Inline (Set_Has_Pragma_Pure);
    pragma Inline (Set_Has_Pragma_Pure_Function);
    pragma Inline (Set_Has_Pragma_Unreferenced);
    pragma Inline (Set_Has_Primitive_Operations);
@@ -6778,6 +6818,7 @@ package Einfo is
    pragma Inline (Set_Is_Intrinsic_Subprogram);
    pragma Inline (Set_Is_Itype);
    pragma Inline (Set_Is_Known_Non_Null);
+   pragma Inline (Set_Is_Known_Null);
    pragma Inline (Set_Is_Known_Valid);
    pragma Inline (Set_Is_Limited_Composite);
    pragma Inline (Set_Is_Limited_Interface);
diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb
index 0dcde3b24d7..255c0db7fb9 100644
--- a/gcc/ada/exp_ch2.adb
+++ b/gcc/ada/exp_ch2.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- --
@@ -25,7 +25,6 @@
 ------------------------------------------------------------------------------
 
 with Atree;    use Atree;
-with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
@@ -42,7 +41,6 @@ with Sem_Util; use Sem_Util;
 with Sem_Warn; use Sem_Warn;
 with Sinfo;    use Sinfo;
 with Snames;   use Snames;
-with Stand;    use Stand;
 with Tbuild;   use Tbuild;
 with Uintp;    use Uintp;
 
@@ -53,13 +51,12 @@ package body Exp_Ch2 is
    -----------------------
 
    procedure Expand_Current_Value (N : Node_Id);
-   --  Given a node N for a variable whose Current_Value field is set.
-   --  If the node is for a discrete type, replaces the node with a
-   --  copy of the referenced value. This provides a limited form of
-   --  value propagation for variables which are initialized or assigned
-   --  not been further modified at the time of reference. The call has
-   --  no effect if the Current_Value refers to a conditional with a
-   --  condition other than equality.
+   --  N is a node for a variable whose Current_Value field is set. If N is
+   --  node is for a discrete type, replaces node with a copy of the referenced
+   --  value. This provides a limited form of value propagation for variables
+   --  which are initialized or assigned not been further modified at the time
+   --  of reference. The call has no effect if the Current_Value refers to a
+   --  conditional with condition other than equality.
 
    procedure Expand_Discriminant (N : Node_Id);
    --  An occurrence of a discriminant within a discriminated type is replaced
@@ -69,42 +66,42 @@ package body Exp_Ch2 is
    --  discriminants of records that appear in constraints of component of the
    --  record, because Gigi uses the discriminant name to retrieve its value.
    --  In the other hand, it has to be performed for default expressions of
-   --  components because they are used in the record init procedure. See
-   --  Einfo for more details, and Exp_Ch3, Exp_Ch9 for examples of use.
-   --  For discriminants of tasks and protected types, the transformation is
-   --  more complex when it occurs within a default expression for an entry
-   --  or protected operation. The corresponding default_expression_function
-   --  has an additional parameter which is the target of an entry call, and
-   --  the discriminant of the task must be replaced with a reference to the
+   --  components because they are used in the record init procedure. See Einfo
+   --  for more details, and Exp_Ch3, Exp_Ch9 for examples of use. For
+   --  discriminants of tasks and protected types, the transformation is more
+   --  complex when it occurs within a default expression for an entry or
+   --  protected operation. The corresponding default_expression_function has
+   --  an additional parameter which is the target of an entry call, and the
+   --  discriminant of the task must be replaced with a reference to the
    --  discriminant of that formal parameter.
 
    procedure Expand_Entity_Reference (N : Node_Id);
    --  Common processing for expansion of identifiers and expanded names
 
    procedure Expand_Entry_Index_Parameter (N : Node_Id);
-   --  A reference to the identifier in the entry index specification
-   --  of a protected entry body is modified to a reference to a constant
-   --  definintion equal to the index of the entry family member being
-   --  called. This constant is calculated as part of the elaboration
-   --  of the expanded code for the body, and is calculated from the
-   --  object-wide entry index returned by Next_Entry_Call.
+   --  A reference to the identifier in the entry index specification of
+   --  protected entry body is modified to a reference to a constant definition
+   --  equal to the index of the entry family member being called. This
+   --  constant is calculated as part of the elaboration of the expanded code
+   --  for the body, and is calculated from the object-wide entry index
+   --  returned by Next_Entry_Call.
 
    procedure Expand_Entry_Parameter (N : Node_Id);
-   --  A reference to an entry parameter is modified to be a reference to
-   --  the corresponding component of the entry parameter record that is
-   --  passed by the runtime to the accept body procedure
+   --  A reference to an entry parameter is modified to be a reference to the
+   --  corresponding component of the entry parameter record that is passed by
+   --  the runtime to the accept body procedure
 
    procedure Expand_Formal (N : Node_Id);
-   --  A reference to a formal parameter of a protected subprogram is
-   --  expanded to the corresponding formal of the unprotected procedure
-   --  used to represent the protected subprogram within the protected object.
+   --  A reference to a formal parameter of a protected subprogram is expanded
+   --  to the corresponding formal of the unprotected procedure used to
+   --  represent the protected subprogram within the protected object.
 
    procedure Expand_Protected_Private (N : Node_Id);
-   --  A reference to a private object of a protected type is expanded
-   --  to a component selected from the record used to implement
-   --  the protected object. Such a record is passed to all operations
-   --  on a protected object in a parameter named _object. Such an object
-   --  is a constant within a function, and a variable otherwise.
+   --  A reference to a private object of a protected type is expanded to a
+   --  component selected from the record used to implement the protected
+   --  object. Such a record is passed to all operations on a protected object
+   --  in a parameter named _object. Such an object is a constant within a
+   --  function, and a variable otherwise.
 
    procedure Expand_Renaming (N : Node_Id);
    --  For renamings, just replace the identifier by the corresponding
@@ -124,51 +121,6 @@ package body Exp_Ch2 is
       Val : Node_Id;
       Op  : Node_Kind;
 
-      function In_Appropriate_Scope return Boolean;
-      --  Returns true if the current scope is the scope of E, or is a nested
-      --  (to any level) package declaration, package body, or block of this
-      --  scope. The idea is that such references are in the sequential
-      --  execution sequence of statements executed after E is elaborated.
-
-      --------------------------
-      -- In_Appropriate_Scope --
-      --------------------------
-
-      function In_Appropriate_Scope return Boolean is
-         ES : constant Entity_Id := Scope (E);
-         CS : Entity_Id;
-
-      begin
-         CS := Current_Scope;
-
-         loop
-            --  If we are in right scope, replacement is safe
-
-            if CS = ES then
-               return True;
-
-            --  Packages do not affect the determination of safety
-
-            elsif Ekind (CS) = E_Package then
-               CS := Scope (CS);
-               exit when CS = Standard_Standard;
-
-            --  Blocks do not affect the determination of safety
-
-            elsif Ekind (CS) = E_Block then
-               CS := Scope (CS);
-
-            --  Otherwise, the reference is dubious, and we cannot be
-            --  sure that it is safe to do the replacement.
-
-            else
-               exit;
-            end if;
-         end loop;
-
-         return False;
-      end In_Appropriate_Scope;
-
    --  Start of processing for Expand_Current_Value
 
    begin
@@ -191,25 +143,9 @@ package body Exp_Ch2 is
 
          and then not Is_Lvalue (N)
 
-         --  Do not replace occurrences that are not in the current scope,
-         --  because in a nested subprogram we know absolutely nothing about
-         --  the sequence of execution.
-
-         and then In_Appropriate_Scope
-
-         --  Do not replace statically allocated objects, because they may
-         --  be modified outside the current scope.
-
-         and then not Is_Statically_Allocated (E)
-
-         --  Do not replace aliased or volatile objects, since we don't know
-         --  what else might change the value
-
-         and then not Is_Aliased (E) and then not Treat_As_Volatile (E)
-
-         --  Debug flag -gnatdM disconnects this optimization
+         --  Check that entity is suitable for replacement
 
-         and then not Debug_Flag_MM
+         and then OK_To_Do_Constant_Replacement (E)
 
          --  Do not replace occurrences in pragmas (where names typically
          --  appear not as values, but as simply names. If there are cases
@@ -316,11 +252,11 @@ package body Exp_Ch2 is
             Parent_P := Parent (Parent_P);
          end loop;
 
-         --  If the discriminant occurs within the default expression for
-         --  a formal of an entry or protected operation, create a default
-         --  function for it, and replace the discriminant with a reference
-         --  to the discriminant of the formal of the default function.
-         --  The discriminant entity is the one defined in the corresponding
+         --  If the discriminant occurs within the default expression for a
+         --  formal of an entry or protected operation, create a default
+         --  function for it, and replace the discriminant with a reference to
+         --  the discriminant of the formal of the default function. The
+         --  discriminant entity is the one defined in the corresponding
          --  record.
 
          if Present (Parent_P)
@@ -422,8 +358,8 @@ package body Exp_Ch2 is
       then
          Expand_Current_Value (N);
 
-         --  We do want to warn for the case of a boolean variable (not
-         --  a boolean constant) whose value is known at compile time.
+         --  We do want to warn for the case of a boolean variable (not a
+         --  boolean constant) whose value is known at compile time.
 
          if Is_Boolean_Type (Etype (N)) then
             Warn_On_Known_Condition (N);
@@ -454,8 +390,8 @@ package body Exp_Ch2 is
       P_Comp_Ref : Entity_Id;
 
       function In_Assignment_Context (N : Node_Id) return Boolean;
-      --  Check whether this is a context in which the entry formal may
-      --  be assigned to.
+      --  Check whether this is a context in which the entry formal may be
+      --  assigned to.
 
       ---------------------------
       -- In_Assignment_Context --
@@ -491,13 +427,12 @@ package body Exp_Ch2 is
       if Is_Task_Type (Scope (Ent_Spec))
         and then Comes_From_Source (Ent_Formal)
       then
-         --  Before replacing the formal with the local renaming that is
-         --  used in the accept block, note if this is an assignment
-         --  context, and note the modification to avoid spurious warnings,
-         --  because the original entity is not used further.
-         --  If the formal is unconstrained, we also generate an extra
-         --  parameter to hold the Constrained attribute of the actual. No
-         --  renaming is generated for this flag.
+         --  Before replacing the formal with the local renaming that is used
+         --  in the accept block, note if this is an assignment context, and
+         --  note the modification to avoid spurious warnings, because the
+         --  original entity is not used further. If formal is unconstrained,
+         --  we also generate an extra parameter to hold the Constrained
+         --  attribute of the actual. No renaming is generated for this flag.
 
          if Ekind (Entity (N)) /= E_In_Parameter
            and then In_Assignment_Context (N)
@@ -510,11 +445,11 @@ package body Exp_Ch2 is
       end if;
 
       --  What we need is a reference to the corresponding component of the
-      --  parameter record object. The Accept_Address field of the entry
-      --  entity references the address variable that contains the address
-      --  of the accept parameters record. We first have to do an unchecked
-      --  conversion to turn this into a pointer to the parameter record and
-      --  then we select the required parameter field.
+      --  parameter record object. The Accept_Address field of the entry entity
+      --  references the address variable that contains the address of the
+      --  accept parameters record. We first have to do an unchecked conversion
+      --  to turn this into a pointer to the parameter record and then we
+      --  select the required parameter field.
 
       P_Comp_Ref :=
         Make_Selected_Component (Loc,
@@ -525,11 +460,10 @@ package body Exp_Ch2 is
           Selector_Name =>
             New_Reference_To (Entry_Component (Ent_Formal), Loc));
 
-      --  For all types of parameters, the constructed parameter record
-      --  object contains a pointer to the parameter. Thus we must
-      --  dereference them to access them (this will often be redundant,
-      --  since the needed deference is implicit, but no harm is done by
-      --  making it explicit).
+      --  For all types of parameters, the constructed parameter record object
+      --  contains a pointer to the parameter. Thus we must dereference them to
+      --  access them (this will often be redundant, since the needed deference
+      --  is implicit, but no harm is done by making it explicit).
 
       Rewrite (N,
         Make_Explicit_Dereference (Loc, P_Comp_Ref));
@@ -655,8 +589,8 @@ package body Exp_Ch2 is
          end if;
       end if;
 
-      --  The type of the reference is the type of the prival, which may
-      --  differ from that of the original component if it is an itype.
+      --  The type of the reference is the type of the prival, which may differ
+      --  from that of the original component if it is an itype.
 
       Set_Entity (N, Prival (E));
       Set_Etype  (N, Etype (Prival (E)));
@@ -682,10 +616,10 @@ package body Exp_Ch2 is
    begin
       Rewrite (N, New_Copy_Tree (Renamed_Object (E)));
 
-      --  We mark the copy as unanalyzed, so that it is sure to be
-      --  reanalyzed at the top level. This is needed in the packed
-      --  case since we specifically avoided expanding packed array
-      --  references when the renaming declaration was analyzed.
+      --  We mark the copy as unanalyzed, so that it is sure to be reanalyzed
+      --  at the top level. This is needed in the packed case since we
+      --  specifically avoided expanding packed array references when the
+      --  renaming declaration was analyzed.
 
       Reset_Analyzed_Flags (N);
       Analyze_And_Resolve (N, T);
@@ -696,9 +630,9 @@ package body Exp_Ch2 is
    ------------------
 
    --  This would be trivial, simply a test for an identifier that was a
-   --  reference to a formal, if it were not for the fact that a previous
-   --  call to Expand_Entry_Parameter will have modified the reference
-   --  to the identifier. A formal of a protected entity is rewritten as
+   --  reference to a formal, if it were not for the fact that a previous call
+   --  to Expand_Entry_Parameter will have modified the reference to the
+   --  identifier. A formal of a protected entity is rewritten as
 
    --    typ!(recobj).rec.all'Constrained
 
diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb
index d650184913c..a888216d908 100644
--- a/gcc/ada/sem_cat.adb
+++ b/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;
diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb
index e538970b5a4..77d28720673 100644
--- a/gcc/ada/sem_ch7.adb
+++ b/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