OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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
This commit is contained in:
Javier Miranda 2006-02-15 10:37:10 +01:00 committed by Arnaud Charlet
parent 1f6a2b51d1
commit ba67390781
5 changed files with 217 additions and 176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
gcc/ada/einfo.adb
View File

@ -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 =>

93
gcc/ada/einfo.ads
View File

@ -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);

198
gcc/ada/exp_ch2.adb
View File

@ -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.
-- Check that entity is suitable for replacement
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
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

16
gcc/ada/sem_cat.adb
View File

@ -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;

8
gcc/ada/sem_ch7.adb
View File

@ -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