From ba6739078139fc22634a0b45c4c34147a14665df Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Wed, 15 Feb 2006 10:37:10 +0100 Subject: [PATCH] einfo.ads, einfo.adb (First_Tag_Component): Protect the frontend against errors in the source program... 2006-02-13 Javier Miranda Robert Dewar Ed Schonberg * 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 | 78 ++++++++++++++--- gcc/ada/einfo.ads | 93 +++++++++++++++------ gcc/ada/exp_ch2.adb | 198 +++++++++++++++----------------------------- gcc/ada/sem_cat.adb | 16 +++- gcc/ada/sem_ch7.adb | 8 +- 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 -- 2.30.2