procedure Check_Vanishing_Fields
(Old_N : Node_Id; New_Kind : Node_Kind)
is
- Old_Kind : constant Node_Kind := Nkind (Old_N);
-
- -- If this fails, it means you need to call Reinit_Field_To_Zero before
- -- calling Mutate_Nkind.
+ -- If this fails, see comments in the spec of Mutate_Nkind and in
+ -- Check_Vanishing_Fields for entities below.
+ Old_Kind : constant Node_Kind := Nkind (Old_N);
begin
for J in Node_Field_Table (Old_Kind)'Range loop
declare
end loop;
end Check_Vanishing_Fields;
+ Check_Vanishing_Fields_Failed : Boolean := False;
+
procedure Check_Vanishing_Fields
(Old_N : Entity_Id; New_Kind : Entity_Kind)
is
+ -- If this fails, it means Mutate_Ekind is changing the Ekind from
+ -- Old_Kind to New_Kind, such that some field F exists in Old_Kind but
+ -- not in New_Kind, and F contains non-default information. The usual
+ -- solution is to call Reinit_Field_To_Zero before calling Mutate_Ekind.
+ -- Another solution is to change Gen_IL so that the new field DOES exist
+ -- in New_Kind. See also comments in the spec of Mutate_Ekind.
+
Old_Kind : constant Entity_Kind := Ekind (Old_N);
- -- If this fails, it means you need to call Reinit_Field_To_Zero before
- -- calling Mutate_Ekind. But we have many cases where vanishing fields
- -- are expected to reappear after converting to/from E_Void. Other cases
- -- are more problematic; set a breakpoint on "(non-E_Void case)" below.
+ function Same_Node_To_Fetch_From
+ (N : Node_Or_Entity_Id; Field : Node_Or_Entity_Field)
+ return Boolean;
+ -- True if the field should be fetched from N. For most fields, this is
+ -- true. However, if the field is a "root type only" field, then this is
+ -- true only if N is the root type. If this is false, then we should not
+ -- do Reinit_Field_To_Zero, and we should not fail below, because the
+ -- field is not vanishing from the root type. Similar comments apply to
+ -- "base type only" and "implementation base type only" fields.
+ --
+ -- We need to ignore exceptions here, because in some cases,
+ -- Node_To_Fetch_From is being called before the relevant (root, base)
+ -- type has been set, so we fail some assertions.
+
+ function Same_Node_To_Fetch_From
+ (N : Node_Or_Entity_Id; Field : Node_Or_Entity_Field)
+ return Boolean is
+ begin
+ return N = Node_To_Fetch_From (N, Field);
+ exception
+ when others => return False; -- ignore the exception
+ end Same_Node_To_Fetch_From;
begin
+ -- Disable these checks in the case of converting to or from E_Void,
+ -- because we have many cases where we convert something to E_Void and
+ -- then back (or then to something else), and Reinit_Field_To_Zero
+ -- wouldn't work because we expect the fields to retain their values.
+
+ if New_Kind = E_Void or else Old_Kind = E_Void then
+ return;
+ end if;
+
for J in Entity_Field_Table (Old_Kind)'Range loop
declare
F : constant Entity_Field := Entity_Field_Table (Old_Kind) (J);
begin
- if not Field_Checking.Field_Present (New_Kind, F) then
+ if not Same_Node_To_Fetch_From (Old_N, F) then
+ null; -- no check in this case
+ elsif not Field_Checking.Field_Present (New_Kind, F) then
if not Field_Is_Initial_Zero (Old_N, F) then
+ Check_Vanishing_Fields_Failed := True;
+ Write_Str ("# ");
Write_Str (Old_Kind'Img);
Write_Str (" --> ");
Write_Str (New_Kind'Img);
Write_Str (" Nonzero field ");
Write_Str (F'Img);
- Write_Str (" is vanishing for node ");
- Write_Int (Nat (Old_N));
- Write_Eol;
+ Write_Str (" is vanishing ");
if New_Kind = E_Void or else Old_Kind = E_Void then
- Write_Line (" (E_Void case)");
+ Write_Line ("(E_Void case)");
else
- Write_Line (" (non-E_Void case)");
+ Write_Line ("(non-E_Void case)");
end if;
+
+ Write_Str (" ...mutating node ");
+ Write_Int (Nat (Old_N));
+ Write_Line ("");
end if;
end if;
end;
end loop;
+
+ if Check_Vanishing_Fields_Failed then
+ raise Program_Error;
+ end if;
end Check_Vanishing_Fields;
- Nkind_Offset : constant Field_Offset :=
- Field_Descriptors (F_Nkind).Offset;
+ Nkind_Offset : constant Field_Offset := Field_Descriptors (F_Nkind).Offset;
procedure Set_Node_Kind_Type is new Set_8_Bit_Field (Node_Kind) with Inline;
Mutate_Nkind (N, Val, Old_Size => Size_In_Slots_Dynamic (N));
end Mutate_Nkind;
- Ekind_Offset : constant Field_Offset :=
- Field_Descriptors (F_Ekind).Offset;
+ Ekind_Offset : constant Field_Offset := Field_Descriptors (F_Ekind).Offset;
procedure Set_Entity_Kind_Type is new Set_8_Bit_Field (Entity_Kind)
with Inline;
-- find the first discriminant if discriminants are present.
-- First_Entity
--- Defined in all entities which act as scopes to which a list of
--- associated entities is attached (blocks, class subtypes and types,
--- entries, functions, loops, packages, procedures, protected objects,
--- record types and subtypes, private types, task types and subtypes).
+-- Defined in all entities that act as scopes to which a list of
+-- associated entities is attached. This is defined in all [sub]types,
+-- including things like scalars that cannot have nested entities,
+-- which makes it more convenient to Mutate_Entity between type kinds.
-- Points to a list of associated entities using the Next_Entity field
-- as a chain pointer with Empty marking the end of the list.
+-- See also Last_Entity.
-- First_Exit_Statement
-- Defined in E_Loop entity. The exit statements for a loop are chained
-- statements whose value is not used.
-- Last_Entity
--- Defined in all entities which act as scopes to which a list of
--- associated entities is attached (blocks, class subtypes and types,
--- entries, functions, loops, packages, procedures, protected objects,
--- record types and subtypes, private types, task types and subtypes).
--- Points to the last entry in the list of associated entities chained
--- through the Next_Entity field. Empty if no entities are chained.
+-- Defined for the same entity kinds as First_Entity. Last_Entity
+-- is the last entry in the list. Empty if no entities are chained.
-- Last_Formal (synthesized)
-- Applies to subprograms and subprogram types, and also in entries
-- field may be set as a result of a linker section pragma applied to the
-- type of the object.
--- Lit_Hash
+-- Lit_Hash [root type only]
-- Defined in enumeration types and subtypes. Non-empty only for the
-- case of an enumeration root type, where it contains the entity for
-- the generated hash function. See unit Exp_Imgv for full details of
-- share the same storage pool).
-- Stored_Constraint
--- Defined in entities that can have discriminants (concurrent types
--- subtypes, record types and subtypes, private types and subtypes,
--- limited private types and subtypes and incomplete types). Points
--- to an element list containing the expressions for each of the
--- stored discriminants for the record (sub)type.
+-- Defined in type entities. Points to an element list containing the
+-- expressions for each of the stored discriminants, if any, for the
+-- (sub)type.
-- Stores_Attribute_Old_Prefix
-- Defined in constants, variables, and types which are created during
Analyze (Init_Decl);
Init_Name := Defining_Identifier (Init_Decl);
+ Reinit_Field_To_Zero (Init_Name, F_Has_Initial_Value,
+ Old_Ekind => (E_Variable => True, others => False));
+ Reinit_Field_To_Zero (Init_Name, F_Is_Elaboration_Checks_OK_Id);
+ Reinit_Field_To_Zero (Init_Name, F_Is_Elaboration_Warnings_OK_Id);
+ Reinit_Field_To_Zero (Init_Name, F_SPARK_Pragma);
+ Reinit_Field_To_Zero (Init_Name, F_SPARK_Pragma_Inherited);
Mutate_Ekind (Init_Name, E_Loop_Parameter);
-- The cursor was marked as a loop parameter to prevent user assignments
Set_Assignment_OK (Cursor_Decl);
Insert_Action (N, Cursor_Decl);
+ Reinit_Field_To_Zero (Cursor, F_Has_Initial_Value,
+ Old_Ekind => (E_Variable => True, others => False));
+ Reinit_Field_To_Zero (Cursor, F_Is_Elaboration_Checks_OK_Id);
+ Reinit_Field_To_Zero (Cursor, F_Is_Elaboration_Warnings_OK_Id);
+ Reinit_Field_To_Zero (Cursor, F_SPARK_Pragma);
+ Reinit_Field_To_Zero (Cursor, F_SPARK_Pragma_Inherited);
Mutate_Ekind (Cursor, Id_Kind);
end;
-- resolution on calls).
(Sm (Alignment, Unat),
Sm (Contract, Node_Id),
+ Sm (First_Entity, Node_Id),
+ Sm (Last_Entity, Node_Id),
Sm (Is_Elaboration_Warnings_OK_Id, Flag),
Sm (Original_Record_Component, Node_Id),
Sm (Scope_Depth_Value, Unat),
Sm (Esize, Uint),
Sm (RM_Size, Uint),
Sm (Extra_Formal, Node_Id),
- Sm (First_Entity, Node_Id),
Sm (Generic_Homonym, Node_Id),
Sm (Generic_Renamings, Elist_Id),
Sm (Handler_Records, List_Id),
Sm (Has_Static_Discriminants, Flag),
Sm (Inner_Instances, Elist_Id),
Sm (Interface_Name, Node_Id),
- Sm (Last_Entity, Node_Id),
Sm (Next_Inlined_Subprogram, Node_Id),
Sm (Renamed_Or_Alias, Node_Id), -- See Einfo.Utils
Sm (Return_Applies_To, Node_Id),
Sm (Predicates_Ignored, Flag),
Sm (Esize, Uint),
Sm (Finalize_Storage_Only, Flag, Base_Type_Only),
+ Sm (First_Entity, Node_Id),
+ Sm (Last_Entity, Node_Id),
Sm (Full_View, Node_Id),
Sm (Has_Completion_In_Body, Flag),
Sm (Has_Constrained_Partial_View, Flag, Base_Type_Only),
Sm (Subprograms_For_Type, Elist_Id),
Sm (Suppress_Initialization, Flag),
Sm (Universal_Aliasing, Flag, Impl_Base_Type_Only),
- Sm (Renamed_Or_Alias, Node_Id)));
+ Sm (Renamed_Or_Alias, Node_Id),
+ Sm (Stored_Constraint, Elist_Id)));
Ab (Elementary_Kind, Type_Kind);
Cc (E_Enumeration_Type, Enumeration_Kind,
-- Enumeration types, created by an enumeration type declaration
- (Sm (Enum_Pos_To_Rep, Node_Id),
- Sm (First_Entity, Node_Id)));
+ (Sm (Enum_Pos_To_Rep, Node_Id)));
Cc (E_Enumeration_Subtype, Enumeration_Kind);
-- Enumeration subtypes, created by an explicit or implicit subtype
Ab (Integer_Kind, Discrete_Kind,
(Sm (Has_Shift_Operator, Flag, Base_Type_Only)));
- Ab (Signed_Integer_Kind, Integer_Kind,
- (Sm (First_Entity, Node_Id)));
+ Ab (Signed_Integer_Kind, Integer_Kind);
Cc (E_Signed_Integer_Type, Signed_Integer_Kind);
-- Signed integer type, used for the anonymous base type of the
-- context does not provide one, the backend will see Allocator_Type
-- itself (which will already have been frozen).
- Cc (E_General_Access_Type, Access_Kind,
+ Cc (E_General_Access_Type, Access_Kind);
-- An access type created by an access type declaration with the all
-- keyword present.
- (Sm (First_Entity, Node_Id)));
Ab (Access_Subprogram_Kind, Access_Kind);
Cc (E_Array_Type, Array_Kind,
-- An array type created by an array type declaration. Includes all
-- cases of arrays, except for string types.
- (Sm (First_Entity, Node_Id),
- Sm (Static_Real_Or_String_Predicate, Node_Id)));
+ (Sm (Static_Real_Or_String_Predicate, Node_Id)));
Cc (E_Array_Subtype, Array_Kind,
-- An array subtype, created by an explicit array subtype declaration,
-- or the use of an anonymous array subtype.
(Sm (Predicated_Parent, Node_Id),
- Sm (First_Entity, Node_Id),
Sm (Static_Real_Or_String_Predicate, Node_Id)));
Cc (E_String_Literal_Subtype, Array_Kind,
Ab (Class_Wide_Kind, Aggregate_Kind,
(Sm (C_Pass_By_Copy, Flag, Impl_Base_Type_Only),
Sm (Equivalent_Type, Node_Id),
- Sm (First_Entity, Node_Id),
Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only),
Sm (Has_Record_Rep_Clause, Flag, Impl_Base_Type_Only),
Sm (Interfaces, Elist_Id),
- Sm (Last_Entity, Node_Id),
Sm (No_Reordering, Flag, Impl_Base_Type_Only),
Sm (Non_Limited_View, Node_Id),
Sm (Parent_Subtype, Node_Id, Base_Type_Only),
- Sm (Reverse_Bit_Order, Flag, Base_Type_Only),
- Sm (Stored_Constraint, Elist_Id)));
+ Sm (Reverse_Bit_Order, Flag, Base_Type_Only)));
Cc (E_Class_Wide_Type, Class_Wide_Kind,
-- A class wide type, created by any tagged type declaration (i.e. if
Sm (Corresponding_Concurrent_Type, Node_Id),
Sm (Corresponding_Remote_Type, Node_Id),
Sm (Dispatch_Table_Wrappers, Elist_Id, Impl_Base_Type_Only),
- Sm (First_Entity, Node_Id),
Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only),
Sm (Has_Record_Rep_Clause, Flag, Impl_Base_Type_Only),
Sm (Interfaces, Elist_Id),
- Sm (Last_Entity, Node_Id),
Sm (No_Reordering, Flag, Impl_Base_Type_Only),
Sm (Parent_Subtype, Node_Id, Base_Type_Only),
Sm (Reverse_Bit_Order, Flag, Base_Type_Only),
- Sm (Stored_Constraint, Elist_Id),
Sm (Underlying_Record_View, Node_Id)));
Cc (E_Record_Subtype, Aggregate_Kind,
Sm (Corresponding_Remote_Type, Node_Id),
Sm (Predicated_Parent, Node_Id),
Sm (Dispatch_Table_Wrappers, Elist_Id, Impl_Base_Type_Only),
- Sm (First_Entity, Node_Id),
Sm (Has_Complex_Representation, Flag, Impl_Base_Type_Only),
Sm (Has_Record_Rep_Clause, Flag, Impl_Base_Type_Only),
Sm (Interfaces, Elist_Id),
- Sm (Last_Entity, Node_Id),
Sm (No_Reordering, Flag, Impl_Base_Type_Only),
Sm (Parent_Subtype, Node_Id, Base_Type_Only),
Sm (Reverse_Bit_Order, Flag, Base_Type_Only),
- Sm (Stored_Constraint, Elist_Id),
Sm (Underlying_Record_View, Node_Id)));
Ab (Incomplete_Or_Private_Kind, Composite_Kind,
- (Sm (First_Entity, Node_Id),
- Sm (Last_Entity, Node_Id),
- Sm (Private_Dependents, Elist_Id),
- Sm (Stored_Constraint, Elist_Id)));
+ (Sm (Private_Dependents, Elist_Id)));
Ab (Private_Kind, Incomplete_Or_Private_Kind,
(Sm (Underlying_Full_View, Node_Id)));
Ab (Concurrent_Kind, Composite_Kind,
(Sm (Corresponding_Record_Type, Node_Id),
- Sm (First_Entity, Node_Id),
Sm (First_Private_Entity, Node_Id),
- Sm (Last_Entity, Node_Id),
- Sm (Scope_Depth_Value, Unat),
- Sm (Stored_Constraint, Elist_Id)));
+ Sm (Scope_Depth_Value, Unat)));
Ab (Task_Kind, Concurrent_Kind,
(Sm (Has_Storage_Size_Clause, Flag, Impl_Base_Type_Only),
(Sm (Access_Subprogram_Wrapper, Node_Id),
Sm (Extra_Accessibility_Of_Result, Node_Id),
Sm (Extra_Formals, Node_Id),
- Sm (First_Entity, Node_Id),
- Sm (Last_Entity, Node_Id),
Sm (Needs_No_Actuals, Flag)));
Ab (Overloadable_Kind, Entity_Kind,
Set_Subtype_Indication (Decl,
New_Occurrence_Of (Non_Lim_View, Sloc (Def_Id)));
Set_Etype (Def_Id, Non_Lim_View);
+ Reinit_Field_To_Zero (Def_Id, F_Non_Limited_View,
+ Old_Ekind => (E_Incomplete_Subtype => True,
+ others => False));
+ Reinit_Field_To_Zero (Def_Id, F_Private_Dependents);
Mutate_Ekind
(Def_Id, Subtype_Kind (Ekind (Non_Lim_View)));
Set_Analyzed (Decl, False);
end if;
if Nkind (Def) = N_Constrained_Array_Definition then
-
- if Ekind (T) in Incomplete_Or_Private_Kind then
- Reinit_Field_To_Zero (T, F_Stored_Constraint);
- else
- pragma Assert (Ekind (T) = E_Void);
- end if;
-
-- Establish Implicit_Base as unconstrained base type
Implicit_Base := Create_Itype (E_Array_Type, P, Related_Id, 'B');
-- Unconstrained array case
else pragma Assert (Nkind (Def) = N_Unconstrained_Array_Definition);
-
- if Ekind (T) in Incomplete_Or_Private_Kind then
- Reinit_Field_To_Zero (T, F_Stored_Constraint);
- else
- pragma Assert (Ekind (T) = E_Void);
- end if;
-
Mutate_Ekind (T, E_Array_Type);
Reinit_Size_Align (T);
Set_Etype (T, T);
-- Set common attributes
if Ekind (Derived_Type) in Incomplete_Or_Private_Kind
- and then Ekind (Parent_Base) in Modular_Integer_Kind | Array_Kind
+ and then Ekind (Parent_Base) in Elementary_Kind
then
- Reinit_Field_To_Zero (Derived_Type, F_Stored_Constraint);
+ Reinit_Field_To_Zero (Derived_Type, F_Discriminant_Constraint);
end if;
Set_Scope (Derived_Type, Current_Scope);
Error_Msg_N ("type cannot be used in its own definition", Indic);
end if;
- Mutate_Ekind (T, Ekind (Parent_Type));
- Set_Etype (T, Any_Type);
+ Mutate_Ekind (T, Ekind (Parent_Type));
+ Set_Etype (T, Any_Type);
Set_Scalar_Range (T, Scalar_Range (Any_Type));
-- Initialize the list of primitive operations to an empty list,
if Ekind (CW_Type) in E_Task_Type | E_Protected_Type then
Reinit_Field_To_Zero (CW_Type, F_SPARK_Aux_Pragma_Inherited);
end if;
+
+ elsif Ekind (CW_Type) = E_Record_Type then
+ Reinit_Field_To_Zero (CW_Type, F_Corresponding_Concurrent_Type);
end if;
Mutate_Ekind (CW_Type, E_Class_Wide_Type);
Analyze_And_Resolve (Mod_Expr, Any_Integer);
- if Ekind (T) in Incomplete_Or_Private_Kind then
- Reinit_Field_To_Zero (T, F_Stored_Constraint);
- end if;
-
Set_Etype (T, T);
Mutate_Ekind (T, E_Modular_Integer_Type);
Reinit_Alignment (T);
(E_Function | E_Procedure |
E_Generic_Function | E_Generic_Procedure => True,
others => False));
+ Reinit_Field_To_Zero (Body_Id, F_Needs_No_Actuals);
+ if Ekind (Body_Id) in E_Function | E_Procedure then
+ Reinit_Field_To_Zero (Body_Id, F_Is_Inlined_Always);
+ end if;
Mutate_Ekind (Body_Id, E_Subprogram_Body);
Set_Convention (Body_Id, Convention (Gen_Id));
Set_Is_Obsolescent (Body_Id, Is_Obsolescent (Gen_Id));
Reference_Body_Formals (Spec_Id, Body_Id);
end if;
- Reinit_Field_To_Zero (Body_Id, F_Has_Out_Or_In_Out_Parameter);
- Reinit_Field_To_Zero (Body_Id, F_Needs_No_Actuals,
- Old_Ekind => (E_Function | E_Procedure => True, others => False));
- Reinit_Field_To_Zero (Body_Id, F_Is_Predicate_Function,
- Old_Ekind => (E_Function | E_Procedure => True, others => False));
- Reinit_Field_To_Zero (Body_Id, F_Protected_Subprogram,
+ Reinit_Field_To_Zero (Body_Id, F_Has_Out_Or_In_Out_Parameter,
Old_Ekind => (E_Function | E_Procedure => True, others => False));
+ Reinit_Field_To_Zero (Body_Id, F_Needs_No_Actuals);
+ Reinit_Field_To_Zero (Body_Id, F_Is_Predicate_Function);
+ Reinit_Field_To_Zero (Body_Id, F_Protected_Subprogram);
+ Reinit_Field_To_Zero (Body_Id, F_Is_Inlined_Always);
+ Reinit_Field_To_Zero (Body_Id, F_Is_Generic_Actual_Subprogram);
+ Reinit_Field_To_Zero (Body_Id, F_Is_Primitive_Wrapper);
+ Reinit_Field_To_Zero (Body_Id, F_Is_Private_Primitive);
+ Reinit_Field_To_Zero (Body_Id, F_Original_Protected_Subprogram);
+ Reinit_Field_To_Zero (Body_Id, F_Wrapped_Entity);
if Ekind (Body_Id) = E_Procedure then
Reinit_Field_To_Zero (Body_Id, F_Receiving_Entry);
-- current node otherwise. Note that N was rewritten above, so we must
-- be sure to get the latest Body_Id value.
+ if Ekind (Body_Id) = E_Package then
+ Reinit_Field_To_Zero (Body_Id, F_Body_Needed_For_Inlining);
+ end if;
Mutate_Ekind (Body_Id, E_Package_Body);
Set_Body_Entity (Spec_Id, Body_Id);
Set_Spec_Entity (Body_Id, Spec_Id);
-- constructed later at the freeze point, so indicate that the
-- completion has not been seen yet.
- Reinit_Field_To_Zero (New_S, F_Has_Out_Or_In_Out_Parameter);
- Reinit_Field_To_Zero (New_S, F_Needs_No_Actuals,
+ Reinit_Field_To_Zero (New_S, F_Has_Out_Or_In_Out_Parameter,
Old_Ekind => (E_Function | E_Procedure => True, others => False));
+ Reinit_Field_To_Zero (New_S, F_Needs_No_Actuals);
+ Reinit_Field_To_Zero (New_S, F_Is_Predicate_Function);
+ Reinit_Field_To_Zero (New_S, F_Protected_Subprogram);
+ Reinit_Field_To_Zero (New_S, F_Is_Inlined_Always);
+ Reinit_Field_To_Zero (New_S, F_Is_Generic_Actual_Subprogram);
Mutate_Ekind (New_S, E_Subprogram_Body);
New_S := Rename_Spec;
Set_Has_Completion (Rename_Spec, False);
projects / thirdparty / gcc.git / commitdiff
