-- --
-- 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- --
-- Privals_Chain Elist23
-- Protected_Operation Node23
+ -- DT_Offset_To_Top_Func Node24
-- Obsolescent_Warning Node24
-- Task_Body_Procedure Node24
-- Abstract_Interfaces Elist24
-- 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
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
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;
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);
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
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;
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);
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;
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);
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;
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
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
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);
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));
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));
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 =>
-- --
-- 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- --
-- 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
-- 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
-- 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
-- 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
-- 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
-- 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.
-- 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,
-- 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.
-- 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.
-- 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.
-- 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
-- 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]
-- 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,
-- 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
-- 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)
-- 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)
-- Kill_Tag_Checks (Flag34)
-- Materialize_Entity (Flag168)
-- Needs_Debug_Info (Flag147)
+ -- No_Return (Flag113)
-- Referenced (Flag156)
-- Referenced_As_LHS (Flag36)
-- Suppress_Elaboration_Warnings (Flag148)
-- 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)
-- 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)
-- 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
-- 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)
-- 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)
-- 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)
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;
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;
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;
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);
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);
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);
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);
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);
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);
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);
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);
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);
-- --
-- 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- --
------------------------------------------------------------------------------
with Atree; use Atree;
-with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
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;
-----------------------
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
-- 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
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
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
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)
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);
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 --
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)
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,
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));
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)));
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);
------------------
-- 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
-- --
-- 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- --
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;
-- 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;
-- --
-- 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- --
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
OSDN Git Service
