From: Bob Duff <d...@adacore.com>
In Gen_IL, detect cases where fields could be inherited from
an abstract type instead of being defined in each of two or more
descendants of that type. Raise Illegal when that is the case,
except in specific cases called out as exceptions to this rule.
For every such case, either update the types declared in
Gen_Nodes and Gen_Entities to use inheritance, or add the case
to the list of exceptions where we do not want to use inheritance.
gcc/ada/ChangeLog:
* gen_il-internals.ads: Split Fields field into two fields
Imm_Fields and Fields.
* gen_il-gen.adb: Modify the field-inheritance
algorithm to inherit at each level of the type hierarchy,
rather than just inheriting into concrete types.
For example, if C is a concrete type derived from B,
which is in turn derived from A, we now set the Fields
of B to include those of A. (We had always set the Fields
of C to include those of A and B, and we still do that.)
(Compute_Fields_For_One_Type): Detect cases where a given
field is declared for all descendants of a given abstract
type, in which case we should consider declaring it in
the abstract type, and inheriting it in those descendants.
(Exception_To_Inheritance_Rule): These are the cases where
we could inherit, but we don't want to.
* gen_il-gen-gen_nodes.adb: Move fields up the type hierarchy,
so they are inherited instead of being defined separately.
* gen_il-gen-gen_entities.adb: Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/gen_il-gen-gen_entities.adb | 18 +-
gcc/ada/gen_il-gen-gen_nodes.adb | 291 ++++++++--------------------
gcc/ada/gen_il-gen.adb | 270 +++++++++++++++++++-------
gcc/ada/gen_il-internals.ads | 6 +-
4 files changed, 289 insertions(+), 296 deletions(-)
diff --git a/gcc/ada/gen_il-gen-gen_entities.adb
b/gcc/ada/gen_il-gen-gen_entities.adb
index f887e0c3c99..8cf66b2611d 100644
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -302,7 +302,8 @@ begin -- Gen_IL.Gen.Gen_Entities
-- but not getters; the Ekind is modified before any such getters are
-- called.
- Ab (Exception_Or_Object_Kind, Entity_Kind);
+ Ab (Exception_Or_Object_Kind, Entity_Kind,
+ (Sm (Esize, Uint)));
Ab (Object_Kind, Exception_Or_Object_Kind,
(Sm (Current_Value, Node_Id),
@@ -313,7 +314,6 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Component_Clause, Node_Id),
Sm (Corresponding_Record_Component, Node_Id),
Sm (Entry_Formal, Node_Id),
- Sm (Esize, Uint),
Sm (Interface_Name, Node_Id),
Sm (Normalized_First_Bit, Uint),
Sm (Normalized_Position, Uint),
@@ -334,7 +334,6 @@ begin -- Gen_IL.Gen.Gen_Entities
Ab (Allocatable_Kind, Object_Kind,
(Sm (Activation_Record_Component, Node_Id),
Sm (Alignment, Unat),
- Sm (Esize, Uint),
Sm (Finalization_Master_Node, Node_Id),
Sm (Interface_Name, Node_Id),
Sm (Is_Finalized_Transient, Flag),
@@ -403,7 +402,6 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Default_Expr_Function, Node_Id),
Sm (Default_Value, Node_Id),
Sm (Entry_Component, Node_Id),
- Sm (Esize, Uint),
Sm (Extra_Accessibility, Node_Id),
Sm (Extra_Constrained, Node_Id),
Sm (Extra_Formal, Node_Id),
@@ -433,8 +431,7 @@ begin -- Gen_IL.Gen.Gen_Entities
Ab (Formal_Object_Kind, Object_Kind,
-- Generic formal objects are also objects
- (Sm (Entry_Component, Node_Id),
- Sm (Esize, Uint)));
+ (Sm (Entry_Component, Node_Id)));
Cc (E_Generic_In_Out_Parameter, Formal_Object_Kind,
-- A generic in out parameter, created by the use of a generic in out
@@ -993,7 +990,8 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Static_Call_Helper, Node_Id),
Sm (SPARK_Pragma, Node_Id),
Sm (SPARK_Pragma_Inherited, Flag),
- Sm (Subps_Index, Unat)));
+ Sm (Subps_Index, Unat),
+ Sm (LSP_Subprogram, Node_Id)));
Cc (E_Function, Subprogram_Kind,
-- A function, created by a function declaration or a function body
@@ -1020,7 +1018,6 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Is_Predicate_Function, Flag),
Sm (Is_Primitive_Wrapper, Flag),
Sm (Is_Private_Primitive, Flag),
- Sm (LSP_Subprogram, Node_Id),
Sm (Mechanism, Mechanism_Type),
Sm (Next_Inlined_Subprogram, Node_Id),
Sm (Original_Protected_Subprogram, Node_Id),
@@ -1039,8 +1036,7 @@ begin -- Gen_IL.Gen.Gen_Entities
-- defined concatenation operator created whenever an array is
declared.
-- We do not make normal derived operators explicit in the tree, but
the
-- concatenation operators are made explicit.
- (Sm (Extra_Accessibility_Of_Result, Node_Id),
- Sm (LSP_Subprogram, Node_Id)));
+ (Sm (Extra_Accessibility_Of_Result, Node_Id)));
Cc (E_Procedure, Subprogram_Kind,
-- A procedure, created by a procedure declaration or a procedure
@@ -1068,7 +1064,6 @@ begin -- Gen_IL.Gen.Gen_Entities
Sm (Is_Primitive_Wrapper, Flag),
Sm (Is_Private_Primitive, Flag),
Sm (Is_Valued_Procedure, Flag),
- Sm (LSP_Subprogram, Node_Id),
Sm (Next_Inlined_Subprogram, Node_Id),
Sm (Original_Protected_Subprogram, Node_Id),
Sm (Protected_Subprogram, Node_Id),
@@ -1170,7 +1165,6 @@ begin -- Gen_IL.Gen.Gen_Entities
-- itself uses E_Exception for the Ekind, the implicit type that is
-- created to represent its type uses the Ekind E_Exception_Type.
(Sm (Alignment, Unat),
- Sm (Esize, Uint),
Sm (Interface_Name, Node_Id),
Sm (Is_Raised, Flag),
Sm (Register_Exception_Call, Node_Id),
diff --git a/gcc/ada/gen_il-gen-gen_nodes.adb b/gcc/ada/gen_il-gen-gen_nodes.adb
index 461195b5e34..c83f9ac3ddb 100644
--- a/gcc/ada/gen_il-gen-gen_nodes.adb
+++ b/gcc/ada/gen_il-gen-gen_nodes.adb
@@ -134,17 +134,13 @@ begin -- Gen_IL.Gen.Gen_Nodes
(Sy (Chars, Name_Id, Default_No_Name)));
Ab (N_Entity, N_Has_Etype,
- (Sm (Next_Entity, Node_Id),
+ (Sy (Chars, Name_Id, Default_No_Name),
+ Sm (Next_Entity, Node_Id),
Sm (Scope, Node_Id)));
- Cc (N_Defining_Character_Literal, N_Entity,
- (Sy (Chars, Name_Id, Default_No_Name)));
-
- Cc (N_Defining_Identifier, N_Entity,
- (Sy (Chars, Name_Id, Default_No_Name)));
-
- Cc (N_Defining_Operator_Symbol, N_Entity,
- (Sy (Chars, Name_Id, Default_No_Name)));
+ Cc (N_Defining_Character_Literal, N_Entity);
+ Cc (N_Defining_Identifier, N_Entity);
+ Cc (N_Defining_Operator_Symbol, N_Entity);
Ab (N_Subexpr, N_Has_Etype,
-- Nodes with expression fields
@@ -176,12 +172,12 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sm (Redundant_Use, Flag)));
Ab (N_Direct_Name, N_Has_Entity,
- (Sm (Has_Private_View, Flag),
+ (Sy (Chars, Name_Id, Default_No_Name),
+ Sm (Has_Private_View, Flag),
Sm (Has_Secondary_Private_View, Flag)));
Cc (N_Identifier, N_Direct_Name,
- (Sy (Chars, Name_Id, Default_No_Name),
- Sm (Atomic_Sync_Required, Flag),
+ (Sm (Atomic_Sync_Required, Flag),
Sm (Is_Elaboration_Checks_OK_Node, Flag),
Sm (Is_Elaboration_Warnings_OK_Node, Flag),
Sm (Is_SPARK_Mode_On_Node, Flag),
@@ -189,174 +185,85 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sm (Redundant_Use, Flag)));
Cc (N_Operator_Symbol, N_Direct_Name,
- (Sy (Chars, Name_Id, Default_No_Name),
- Sy (Strval, String_Id)));
+ (Sy (Strval, String_Id)));
Cc (N_Character_Literal, N_Direct_Name,
- (Sy (Chars, Name_Id, Default_No_Name),
- Sy (Char_Literal_Value, Unat)));
+ (Sy (Char_Literal_Value, Unat)));
Ab (N_Op, N_Has_Entity,
- (Sm (Do_Overflow_Check, Flag),
+ (Sm (Chars, Name_Id),
+ Sm (Do_Overflow_Check, Flag),
Sm (Has_Private_View, Flag),
Sm (Has_Secondary_Private_View, Flag)));
- Ab (N_Binary_Op, N_Op);
-
- Cc (N_Op_Add, N_Binary_Op,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
+ Ab (N_Binary_Op, N_Op,
+ (Sy (Left_Opnd, Node_Id),
Sy (Right_Opnd, Node_Id)));
+ Cc (N_Op_Add, N_Binary_Op);
+
Cc (N_Op_Concat, N_Binary_Op,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sm (Is_Component_Left_Opnd, Flag),
+ (Sm (Is_Component_Left_Opnd, Flag),
Sm (Is_Component_Right_Opnd, Flag)));
Cc (N_Op_Expon, N_Binary_Op,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sm (Is_Power_Of_2_For_Shift, Flag)));
+ (Sm (Is_Power_Of_2_For_Shift, Flag)));
- Cc (N_Op_Subtract, N_Binary_Op,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
+ Cc (N_Op_Subtract, N_Binary_Op);
Ab (N_Multiplying_Operator, N_Binary_Op);
Cc (N_Op_Divide, N_Multiplying_Operator,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sm (Do_Division_Check, Flag),
+ (Sm (Do_Division_Check, Flag),
Sm (Rounded_Result, Flag)));
Cc (N_Op_Mod, N_Multiplying_Operator,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sm (Do_Division_Check, Flag)));
+ (Sm (Do_Division_Check, Flag)));
Cc (N_Op_Multiply, N_Multiplying_Operator,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sm (Rounded_Result, Flag)));
+ (Sm (Rounded_Result, Flag)));
Cc (N_Op_Rem, N_Multiplying_Operator,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sm (Do_Division_Check, Flag)));
+ (Sm (Do_Division_Check, Flag)));
Ab (N_Op_Boolean, N_Binary_Op);
-- Binary operators that yield a result of a boolean type
Cc (N_Op_And, N_Op_Boolean,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sm (Do_Length_Check, Flag)));
+ (Sm (Do_Length_Check, Flag)));
- Ab (N_Op_Compare, N_Op_Boolean);
+ Ab (N_Op_Compare, N_Op_Boolean,
+ (Sm (Compare_Type, Node_Id)));
- Cc (N_Op_Eq, N_Op_Compare,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sm (Compare_Type, Node_Id)));
-
- Cc (N_Op_Ge, N_Op_Compare,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sm (Compare_Type, Node_Id)));
-
- Cc (N_Op_Gt, N_Op_Compare,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sm (Compare_Type, Node_Id)));
-
- Cc (N_Op_Le, N_Op_Compare,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sm (Compare_Type, Node_Id)));
-
- Cc (N_Op_Lt, N_Op_Compare,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sm (Compare_Type, Node_Id)));
-
- Cc (N_Op_Ne, N_Op_Compare,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sm (Compare_Type, Node_Id)));
+ Cc (N_Op_Eq, N_Op_Compare);
+ Cc (N_Op_Ge, N_Op_Compare);
+ Cc (N_Op_Gt, N_Op_Compare);
+ Cc (N_Op_Le, N_Op_Compare);
+ Cc (N_Op_Lt, N_Op_Compare);
+ Cc (N_Op_Ne, N_Op_Compare);
Cc (N_Op_Or, N_Op_Boolean,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sm (Do_Length_Check, Flag)));
+ (Sm (Do_Length_Check, Flag)));
Cc (N_Op_Xor, N_Op_Boolean,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sm (Do_Length_Check, Flag)));
+ (Sm (Do_Length_Check, Flag)));
Ab (N_Op_Shift, N_Binary_Op,
(Sm (Shift_Count_OK, Flag)));
- Cc (N_Op_Rotate_Left, N_Op_Shift,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
-
- Cc (N_Op_Rotate_Right, N_Op_Shift,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
-
- Cc (N_Op_Shift_Left, N_Op_Shift,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
-
- Cc (N_Op_Shift_Right, N_Op_Shift,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
-
- Cc (N_Op_Shift_Right_Arithmetic, N_Op_Shift,
- (Sm (Chars, Name_Id),
- Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id)));
-
- Ab (N_Unary_Op, N_Op);
+ Cc (N_Op_Rotate_Left, N_Op_Shift);
+ Cc (N_Op_Rotate_Right, N_Op_Shift);
+ Cc (N_Op_Shift_Left, N_Op_Shift);
+ Cc (N_Op_Shift_Right, N_Op_Shift);
+ Cc (N_Op_Shift_Right_Arithmetic, N_Op_Shift);
- Cc (N_Op_Abs, N_Unary_Op,
- (Sm (Chars, Name_Id),
- Sy (Right_Opnd, Node_Id)));
-
- Cc (N_Op_Minus, N_Unary_Op,
- (Sm (Chars, Name_Id),
- Sy (Right_Opnd, Node_Id)));
-
- Cc (N_Op_Not, N_Unary_Op,
- (Sm (Chars, Name_Id),
- Sy (Right_Opnd, Node_Id)));
+ Ab (N_Unary_Op, N_Op,
+ (Sy (Right_Opnd, Node_Id)));
- Cc (N_Op_Plus, N_Unary_Op,
- (Sm (Chars, Name_Id),
- Sy (Right_Opnd, Node_Id)));
+ Cc (N_Op_Abs, N_Unary_Op);
+ Cc (N_Op_Minus, N_Unary_Op);
+ Cc (N_Op_Not, N_Unary_Op);
+ Cc (N_Op_Plus, N_Unary_Op);
Cc (N_Attribute_Reference, N_Has_Entity,
(Sy (Prefix, Node_Id),
@@ -370,65 +277,47 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sm (Must_Be_Byte_Aligned, Flag),
Sm (Redundant_Use, Flag)));
- Ab (N_Membership_Test, N_Subexpr);
-
- Cc (N_In, N_Membership_Test,
+ Ab (N_Membership_Test, N_Subexpr,
(Sy (Left_Opnd, Node_Id),
Sy (Right_Opnd, Node_Id),
Sy (Alternatives, List_Id, Default_No_List),
Sy (No_Minimize_Eliminate, Flag)));
- Cc (N_Not_In, N_Membership_Test,
- (Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sy (Alternatives, List_Id, Default_No_List),
- Sy (No_Minimize_Eliminate, Flag)));
+ Cc (N_In, N_Membership_Test);
+ Cc (N_Not_In, N_Membership_Test);
- Ab (N_Short_Circuit, N_Subexpr);
-
- Cc (N_And_Then, N_Short_Circuit,
+ Ab (N_Short_Circuit, N_Subexpr,
(Sy (Left_Opnd, Node_Id),
Sy (Right_Opnd, Node_Id),
Sm (Actions, List_Id)));
- Cc (N_Or_Else, N_Short_Circuit,
- (Sy (Left_Opnd, Node_Id),
- Sy (Right_Opnd, Node_Id),
- Sm (Actions, List_Id)));
+ Cc (N_And_Then, N_Short_Circuit);
+ Cc (N_Or_Else, N_Short_Circuit);
Ab (N_Subprogram_Call, N_Subexpr,
- (Sm (Controlling_Argument, Node_Id),
+ (Sy (Name, Node_Id, Default_Empty),
+ Sy (Parameter_Associations, List_Id, Default_No_List),
+ Sm (Controlling_Argument, Node_Id),
Sm (First_Named_Actual, Node_Id),
Sm (Is_Elaboration_Checks_OK_Node, Flag),
Sm (Is_Elaboration_Warnings_OK_Node, Flag),
Sm (Is_Known_Guaranteed_ABE, Flag),
Sm (Is_SPARK_Mode_On_Node, Flag),
- Sm (No_Elaboration_Check, Flag)));
-
- Cc (N_Function_Call, N_Subprogram_Call,
- (Sy (Name, Node_Id, Default_Empty),
- Sy (Parameter_Associations, List_Id, Default_No_List),
- Sm (Is_Expanded_Build_In_Place_Call, Flag),
+ Sm (No_Elaboration_Check, Flag),
Sm (Is_Expanded_Prefixed_Call, Flag)));
- Cc (N_Procedure_Call_Statement, N_Subprogram_Call,
- (Sy (Name, Node_Id, Default_Empty),
- Sy (Parameter_Associations, List_Id, Default_No_List),
- Sm (Is_Expanded_Prefixed_Call, Flag)));
-
- Ab (N_Raise_xxx_Error, N_Subexpr);
+ Cc (N_Function_Call, N_Subprogram_Call,
+ (Sm (Is_Expanded_Build_In_Place_Call, Flag)));
- Cc (N_Raise_Constraint_Error, N_Raise_xxx_Error,
- (Sy (Condition, Node_Id, Default_Empty),
- Sy (Reason, Unat)));
+ Cc (N_Procedure_Call_Statement, N_Subprogram_Call);
- Cc (N_Raise_Program_Error, N_Raise_xxx_Error,
+ Ab (N_Raise_xxx_Error, N_Subexpr,
(Sy (Condition, Node_Id, Default_Empty),
Sy (Reason, Unat)));
- Cc (N_Raise_Storage_Error, N_Raise_xxx_Error,
- (Sy (Condition, Node_Id, Default_Empty),
- Sy (Reason, Unat)));
+ Cc (N_Raise_Constraint_Error, N_Raise_xxx_Error);
+ Cc (N_Raise_Program_Error, N_Raise_xxx_Error);
+ Cc (N_Raise_Storage_Error, N_Raise_xxx_Error);
Ab (N_Numeric_Or_String_Literal, N_Subexpr);
@@ -797,7 +686,10 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sy (Aspect_Specifications, List_Id, Default_No_List)));
Ab (N_Generic_Instantiation, N_Later_Decl_Item,
- (Sm (Instance_Spec, Node_Id),
+ (Sy (Defining_Unit_Name, Node_Id),
+ Sy (Name, Node_Id, Default_Empty),
+ Sy (Generic_Associations, List_Id, Default_No_List),
+ Sm (Instance_Spec, Node_Id),
Sm (Is_Declaration_Level_Node, Flag),
Sm (Is_Elaboration_Checks_OK_Node, Flag),
Sm (Is_Elaboration_Warnings_OK_Node, Flag),
@@ -805,29 +697,16 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sm (Is_SPARK_Mode_On_Node, Flag),
Sm (Parent_Spec, Node_Id)));
- Ab (N_Subprogram_Instantiation, N_Generic_Instantiation);
-
- Cc (N_Function_Instantiation, N_Subprogram_Instantiation,
- (Sy (Defining_Unit_Name, Node_Id),
- Sy (Name, Node_Id, Default_Empty),
- Sy (Generic_Associations, List_Id, Default_No_List),
- Sy (Must_Override, Flag),
+ Ab (N_Subprogram_Instantiation, N_Generic_Instantiation,
+ (Sy (Must_Override, Flag),
Sy (Must_Not_Override, Flag),
Sy (Aspect_Specifications, List_Id, Default_No_List)));
- Cc (N_Procedure_Instantiation, N_Subprogram_Instantiation,
- (Sy (Defining_Unit_Name, Node_Id),
- Sy (Name, Node_Id, Default_Empty),
- Sy (Generic_Associations, List_Id, Default_No_List),
- Sy (Must_Override, Flag),
- Sy (Must_Not_Override, Flag),
- Sy (Aspect_Specifications, List_Id, Default_No_List)));
+ Cc (N_Function_Instantiation, N_Subprogram_Instantiation);
+ Cc (N_Procedure_Instantiation, N_Subprogram_Instantiation);
Cc (N_Package_Instantiation, N_Generic_Instantiation,
- (Sy (Defining_Unit_Name, Node_Id),
- Sy (Name, Node_Id, Default_Empty),
- Sy (Generic_Associations, List_Id, Default_No_List),
- Sy (Aspect_Specifications, List_Id, Default_No_List)));
+ (Sy (Aspect_Specifications, List_Id, Default_No_List)));
Ab (N_Proper_Body, N_Later_Decl_Item,
(Sm (Corresponding_Spec, Node_Id),
@@ -1051,13 +930,11 @@ begin -- Gen_IL.Gen.Gen_Nodes
(Sy (Entry_Call_Alternative, Node_Id),
Sy (Else_Statements, List_Id, Default_No_List)));
- Ab (N_Delay_Statement, N_Statement_Other_Than_Procedure_Call);
-
- Cc (N_Delay_Relative_Statement, N_Delay_Statement,
+ Ab (N_Delay_Statement, N_Statement_Other_Than_Procedure_Call,
(Sy (Expression, Node_Id, Default_Empty)));
- Cc (N_Delay_Until_Statement, N_Delay_Statement,
- (Sy (Expression, Node_Id, Default_Empty)));
+ Cc (N_Delay_Relative_Statement, N_Delay_Statement);
+ Cc (N_Delay_Until_Statement, N_Delay_Statement);
Cc (N_Entry_Call_Statement, N_Statement_Other_Than_Procedure_Call,
(Sy (Name, Node_Id, Default_Empty),
@@ -1183,21 +1060,16 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sy (Pragmas_Before, List_Id, Default_No_List),
Sy (Pragmas_After, List_Id, Default_No_List)));
- Ab (N_Formal_Subprogram_Declaration, Node_Kind);
-
- Cc (N_Formal_Abstract_Subprogram_Declaration,
N_Formal_Subprogram_Declaration,
+ Ab (N_Formal_Subprogram_Declaration, Node_Kind,
(Sy (Specification, Node_Id),
Sy (Default_Name, Node_Id, Default_Empty),
Sy (Expression, Node_Id, Default_Empty),
Sy (Box_Present, Flag),
Sy (Aspect_Specifications, List_Id, Default_No_List)));
- Cc (N_Formal_Concrete_Subprogram_Declaration,
N_Formal_Subprogram_Declaration,
- (Sy (Specification, Node_Id),
- Sy (Default_Name, Node_Id, Default_Empty),
- Sy (Expression, Node_Id, Default_Empty),
- Sy (Box_Present, Flag),
- Sy (Aspect_Specifications, List_Id, Default_No_List)));
+ Cc (N_Formal_Abstract_Subprogram_Declaration,
N_Formal_Subprogram_Declaration);
+
+ Cc (N_Formal_Concrete_Subprogram_Declaration,
N_Formal_Subprogram_Declaration);
Ab (N_Push_Pop_xxx_Label, Node_Kind);
@@ -1205,17 +1077,13 @@ begin -- Gen_IL.Gen.Gen_Nodes
(Sm (Exception_Label, Node_Id)));
Cc (N_Push_Constraint_Error_Label, N_Push_xxx_Label);
-
Cc (N_Push_Program_Error_Label, N_Push_xxx_Label);
-
Cc (N_Push_Storage_Error_Label, N_Push_xxx_Label);
Ab (N_Pop_xxx_Label, N_Push_Pop_xxx_Label);
Cc (N_Pop_Constraint_Error_Label, N_Pop_xxx_Label);
-
Cc (N_Pop_Program_Error_Label, N_Pop_xxx_Label);
-
Cc (N_Pop_Storage_Error_Label, N_Pop_xxx_Label);
Ab (N_SCIL_Node, Node_Kind,
@@ -1437,11 +1305,8 @@ begin -- Gen_IL.Gen.Gen_Nodes
Sy (Interface_List, List_Id, Default_No_List)));
Cc (N_Formal_Discrete_Type_Definition, Node_Kind);
-
Cc (N_Formal_Floating_Point_Definition, Node_Kind);
-
Cc (N_Formal_Modular_Type_Definition, Node_Kind);
-
Cc (N_Formal_Ordinary_Fixed_Point_Definition, Node_Kind);
Cc (N_Formal_Package_Declaration, Node_Kind,
diff --git a/gcc/ada/gen_il-gen.adb b/gcc/ada/gen_il-gen.adb
index da7e96eaf19..5064e8c6eb7 100644
--- a/gcc/ada/gen_il-gen.adb
+++ b/gcc/ada/gen_il-gen.adb
@@ -158,7 +158,7 @@ package body Gen_IL.Gen is
new Type_Info'
(Is_Union => False, Parent => Parent,
Children | Concrete_Descendants => Type_Vectors.Empty_Vector,
- First | Last | Fields => <>, -- filled in later
+ First | Last | Imm_Fields | Fields => <>, -- filled in later
Nmake_Assert => new String'(Nmake_Assert));
if Parent /= No_Type then
@@ -223,7 +223,7 @@ package body Gen_IL.Gen is
begin
Append (Field_Table (Field).Have_This_Field, T);
- Append (Type_Table (T).Fields, Field);
+ Append (Type_Table (T).Imm_Fields, Field);
pragma Assert (not Syntactic (T) (Field));
Syntactic (T) (Field) := Is_Syntactic;
@@ -491,6 +491,9 @@ package body Gen_IL.Gen is
procedure Compile is
Fields_Per_Node : Fields_Per_Node_Type := (others => (others => False));
+ -- Mapping from node types to sets of fields that exist in that node
+ -- type. For abstract types, it's the set of fields that exist in
+ -- all descendants. For union types, currently not used.
Type_Bit_Size : array (Concrete_Type) of Bit_Offset := (others => 0);
Min_Node_Bit_Size : Bit_Offset := Bit_Offset'Last;
@@ -514,21 +517,25 @@ package body Gen_IL.Gen is
-- is needed. Default_Expression is also both, but the Parent is not
-- needed. Then_Actions and Else_Actions are not syntactic, but the
-- Parent is needed.
+ --
+ -- Computed in Check_For_Syntactic_Field_Mismatch.
procedure Check_Completeness;
-- Check that every type and field has been declared
- procedure Compute_Ranges (Root : Root_Type);
- -- Compute the range of Node_Kind/Entity_Kind values for all the types
- -- rooted at Root. The result is stored in the First and Last components
- -- in the Type_Table.
+ procedure Compute_Ranges;
+ -- Compute the range of Node_Kind/Entity_Kind values. The result is
+ -- stored in the First and Last components in the Type_Table.
- procedure Compute_Fields_Per_Node;
+ procedure Inherit_Fields;
-- Compute which fields are in which nodes. Implements inheritance of
-- fields. Set the Fields component of each Type_Info to include
- -- inherited ones. Set the Is_Syntactic component in the Type_Table to
- -- the set of fields that are syntactic in that node kind. Set the
- -- Fields_Per_Node table.
+ -- inherited ones. Check for misc errors.
+
+ procedure Compute_Fields_Per_Node;
+ -- Set the Is_Syntactic component in the Type_Table to the set of fields
+ -- that are syntactic in that node kind. Set the Fields_Per_Node
+ -- table. Check for misc errors.
procedure Compute_Field_Offsets;
-- Compute the offsets of each field. The results are stored in the
@@ -679,7 +686,7 @@ package body Gen_IL.Gen is
-- Compute_Ranges --
--------------------
- procedure Compute_Ranges (Root : Root_Type) is
+ procedure Compute_Ranges is
procedure Do_One_Type (T : Node_Or_Entity_Type);
-- Compute the range for one type. Passed to Iterate_Types to process
@@ -750,20 +757,17 @@ package body Gen_IL.Gen is
end case;
end Do_One_Type;
begin
- Iterate_Types (Root, Post => Do_One_Type'Access);
+ Iterate_Types (Node_Kind, Post => Do_One_Type'Access);
+ Iterate_Types (Entity_Kind, Post => Do_One_Type'Access);
end Compute_Ranges;
- -----------------------------
- -- Compute_Fields_Per_Node --
- -----------------------------
-
- procedure Compute_Fields_Per_Node is
-
- Duplicate_Fields_Found : Boolean := False;
+ --------------------
+ -- Inherit_Fields --
+ --------------------
- function Get_Fields (T : Node_Or_Entity_Type) return Field_Vector;
- -- Compute the fields of a given type. This is the fields inherited
- -- from ancestors, plus the fields declared for the type itself.
+ procedure Inherit_Fields is
+ procedure Inherit_Fields_For_One_Type (T : Node_Or_Entity_Type);
+ -- Compute Fields for one node type
function Get_Syntactic_Fields
(T : Node_Or_Entity_Type) return Field_Set;
@@ -771,17 +775,6 @@ package body Gen_IL.Gen is
-- Note that a field can be syntactic in some node types, but
-- semantic in others.
- procedure Do_Concrete_Type (CT : Concrete_Type);
- -- Do the Compute_Fields_Per_Node work for a concrete type
-
- function Get_Fields (T : Node_Or_Entity_Type) return Field_Vector is
- Parent_Fields : constant Field_Vector :=
- (if T in Root_Type then Field_Vectors.Empty_Vector
- else Get_Fields (Type_Table (T).Parent));
- begin
- return Parent_Fields & Type_Table (T).Fields;
- end Get_Fields;
-
function Get_Syntactic_Fields
(T : Node_Or_Entity_Type) return Field_Set
is
@@ -792,26 +785,23 @@ package body Gen_IL.Gen is
return Parent_Is_Syntactic or Syntactic (T);
end Get_Syntactic_Fields;
- procedure Do_Concrete_Type (CT : Concrete_Type) is
+ procedure Inherit_Fields_For_One_Type (T : Node_Or_Entity_Type) is
begin
- Type_Table (CT).Fields := Get_Fields (CT);
- Syntactic (CT) := Get_Syntactic_Fields (CT);
-
- for F of Type_Table (CT).Fields loop
- if Fields_Per_Node (CT) (F) then
- Ada.Text_IO.Put_Line
- ("duplicate field" & Image (CT) & Image (F));
- Duplicate_Fields_Found := True;
- end if;
+ pragma Assert (Is_Empty (Type_Table (T).Fields));
- Fields_Per_Node (CT) (F) := True;
- end loop;
- end Do_Concrete_Type;
+ if T not in Root_Type then
+ Append
+ (Type_Table (T).Fields,
+ Type_Table (Type_Table (T).Parent).Fields);
+ end if;
- begin -- Compute_Fields_Per_Node
- for CT in Concrete_Node loop
- Do_Concrete_Type (CT);
- end loop;
+ Append (Type_Table (T).Fields, Type_Table (T).Imm_Fields);
+ Syntactic (T) := Get_Syntactic_Fields (T);
+ end Inherit_Fields_For_One_Type;
+
+ begin -- Inherit_Fields
+
+ Iterate_Types (Node_Kind, Pre => Inherit_Fields_For_One_Type'Access);
-- The node fields defined for all three N_Entity kinds should be the
-- same:
@@ -832,6 +822,126 @@ package body Gen_IL.Gen is
"N_Defining_Operator_Symbol must match";
end if;
+ -- Copy node fields from N_Entity nodes to entities, so they have
+ -- slots allocated (but the getters and setters are only in
+ -- Sinfo.Nodes).
+
+ Type_Table (Entity_Kind).Imm_Fields :=
+ Type_Table (N_Defining_Identifier).Fields &
+ Type_Table (Entity_Kind).Imm_Fields;
+
+ Iterate_Types
+ (Entity_Kind, Pre => Inherit_Fields_For_One_Type'Access);
+ end Inherit_Fields;
+
+ -----------------------------
+ -- Compute_Fields_Per_Node --
+ -----------------------------
+
+ procedure Compute_Fields_Per_Node is
+ Duplicate_Fields_Error, Could_Be_Inherited_Error : Boolean := False;
+
+ procedure Compute_Fields_For_One_Type (T : Node_Or_Entity_Type);
+ -- Do the computations for one type
+
+ procedure Check_Potential_Inheritance (T : Node_Or_Entity_Type);
+ -- Check whether fields could be inherited from T, instead of
+ -- defining them separately for descendants.
+
+ procedure Compute_Fields_For_One_Type (T : Node_Or_Entity_Type) is
+ begin
+ case T is
+ when Concrete_Type =>
+ for F of Type_Table (T).Fields loop
+ if Fields_Per_Node (T) (F) then
+ Ada.Text_IO.Put_Line
+ ("duplicate field " & Image (T) & " " & Image (F));
+ Duplicate_Fields_Error := True;
+ end if;
+
+ Fields_Per_Node (T) (F) := True;
+ end loop;
+
+ when Abstract_Type =>
+ -- Fields_Per_Node for an abstract type is the set of fields
+ -- that exist in ALL children; that is, the intersection of
+ -- the Fields_Per_Node for the children; hence "and" below.
+
+ pragma Assert (not Is_Empty (Type_Table (T).Children));
+ -- Otherwise, the following loop won't work
+
+ pragma Assert (Fields_Per_Node (T) = (Field_Enum => False));
+ Fields_Per_Node (T) := (Field_Enum => True);
+
+ for Child of Type_Table (T).Children loop
+ pragma Assert
+ (Fields_Per_Node (Child) /= (Field_Enum => False));
+ Fields_Per_Node (T) :=
+ Fields_Per_Node (T) and Fields_Per_Node (Child);
+ end loop;
+
+ when Between_Abstract_Entity_And_Concrete_Node_Types =>
+ raise Program_Error;
+ end case;
+ end Compute_Fields_For_One_Type;
+
+ procedure Check_Potential_Inheritance (T : Node_Or_Entity_Type) is
+
+ function Exception_To_Inheritance_Rule
+ (T : Node_Or_Entity_Type; F : Field_Enum) return Boolean is
+ -- True if we should allow this case as an exception to
+ -- the Could_Be_Inherited_Error rule; if this is False,
+ -- we complain. This is somewhat ad hoc. The most common
+ -- reason is to keep syntactic fields in order.
+ -- For example, Left_Opnd comes before Right_Opnd,
+ -- which wouldn't be the case if Right_Opnd were
+ -- inherited from N_Op.
+ ((T = N_Op and then F = Right_Opnd)
+ or else (T = N_Renaming_Declaration and then F = Name)
+ or else (T = N_Generic_Renaming_Declaration and then F = Name)
+ or else F in Defining_Unit_Name
+ | Aspect_Specifications
+ | At_End_Proc
+ | Handled_Statement_Sequence
+ | Declarations
+ | Generic_Formal_Declarations
+ | Specification
+ | Component_Definition
+ | Renamed_Or_Alias
+ or else T in N_Subprogram_Specification
+ | N_Access_Function_Definition
+ | N_Access_To_Subprogram_Definition
+ | Void_Or_Type_Kind);
+
+ begin
+ if T in Abstract_Type then
+ for F in Field_Enum loop
+ if Fields_Per_Node (T) (F)
+ and then not
+ (for some FF of Type_Table (T).Fields => F = FF)
+ and then not Exception_To_Inheritance_Rule (T, F)
+ then
+ Ada.Text_IO.Put_Line
+ (Image (F) & " could be inherited from " & Image (T) &
+ "; this field is present in all descendants");
+ Could_Be_Inherited_Error := True;
+ end if;
+ end loop;
+ end if;
+ end Check_Potential_Inheritance;
+
+ begin -- Compute_Fields_Per_Node
+
+ -- First walk the types bottom-up, and for each type, call
+ -- Compute_Fields_For_One_Type. Then walk top-down, calling
+ -- Check_Potential_Inheritance to check for cases where
+ -- inheritance could be used.
+
+ Iterate_Types (Node_Kind, Post => Compute_Fields_For_One_Type'Access);
+
+ -- The node fields defined for all three N_Entity kinds should be the
+ -- same:
+
if Fields_Per_Node (N_Defining_Character_Literal) /=
Fields_Per_Node (N_Defining_Identifier)
then
@@ -848,20 +958,40 @@ package body Gen_IL.Gen is
"N_Defining_Identifier";
end if;
- -- Copy node fields from N_Entity nodes to entities, so they have
- -- slots allocated (but the getters and setters are only in
- -- Sinfo.Nodes).
+ Iterate_Types
+ (Entity_Kind, Post => Compute_Fields_For_One_Type'Access);
- Type_Table (Entity_Kind).Fields :=
- Type_Table (N_Defining_Identifier).Fields &
- Type_Table (Entity_Kind).Fields;
+ if Duplicate_Fields_Error then
+ raise Illegal with "duplicate fields found";
+ end if;
+ for CT in Concrete_Node loop
+ pragma Assert (Fields_Per_Node (CT) /= (Field_Enum => False));
+ end loop;
for CT in Concrete_Entity loop
- Do_Concrete_Type (CT);
+ pragma Assert (Fields_Per_Node (CT) /= (Field_Enum => False));
+ end loop;
+ for AbT in Abstract_Node loop
+ pragma Assert
+ (Type_Table (AbT).Is_Union = -- if and only if
+ (Fields_Per_Node (AbT) = (Field_Enum => False)));
+ end loop;
+ for AbT in Abstract_Entity loop
+ pragma Assert
+ (Type_Table (AbT).Is_Union = -- if and only if
+ (Fields_Per_Node (AbT) = (Field_Enum => False)));
end loop;
- if Duplicate_Fields_Found then
- raise Illegal with "duplicate fields found";
+ Iterate_Types (Node_Kind, Pre => Check_Potential_Inheritance'Access);
+ Iterate_Types (Entity_Kind, Pre =>
Check_Potential_Inheritance'Access);
+
+ if Could_Be_Inherited_Error then
+ raise Illegal with "some fields could be inherited";
+ -- If you get this error, then either move the relevant fields
+ -- upward in the type hierarchy, or add a case to the
+ -- Exception_To_Inheritance_Rule function above.
+ -- We don't always want to use inheritance when it's possible;
+ -- for example, we might want to control the order of fields.
end if;
end Compute_Fields_Per_Node;
@@ -1027,13 +1157,13 @@ package body Gen_IL.Gen is
package Sorting is new Field_Vectors.Generic_Sorting
("<" => Sort_Less);
- All_Fields : Field_Vector;
+ Fields : Field_Vector;
-- Start of processing for Compute_Field_Offsets
begin
- -- Compute the number of types that have each field, weighted by the
- -- frequency of such nodes.
+ -- Compute the number of concrete types that have each field,
+ -- weighted by the frequency of such nodes.
for T in Concrete_Type loop
for F in Field_Enum loop
@@ -1044,21 +1174,21 @@ package body Gen_IL.Gen is
end loop;
end loop;
- -- Collect all the fields in All_Fields
+ -- Collect all the fields in Fields
for F in Node_Field loop
- Append (All_Fields, F);
+ Append (Fields, F);
end loop;
for F in Entity_Field loop
- Append (All_Fields, F);
+ Append (Fields, F);
end loop;
- -- Sort All_Fields based on how many concrete types have the field.
+ -- Sort Fields based on how many concrete types have the field.
-- This is for efficiency; we want to choose the offsets of the most
-- common fields first, so they get low numbers.
- Sorting.Sort (All_Fields);
+ Sorting.Sort (Fields);
-- Go through all the fields, and choose the lowest offset that is
-- free in all types that have the field. This is basically a
@@ -1093,7 +1223,7 @@ package body Gen_IL.Gen is
-- Then loop through them all, skipping the ones we did above
- for F of All_Fields loop
+ for F of Fields loop
if Field_Table (F).Offset = Unknown_Offset then
Choose_Offset (F);
end if;
@@ -3259,8 +3389,8 @@ package body Gen_IL.Gen is
Check_Completeness;
- Compute_Ranges (Node_Kind);
- Compute_Ranges (Entity_Kind);
+ Compute_Ranges;
+ Inherit_Fields;
Compute_Fields_Per_Node;
Compute_Field_Offsets;
Compute_Type_Sizes;
diff --git a/gcc/ada/gen_il-internals.ads b/gcc/ada/gen_il-internals.ads
index 46d38d0baaa..3c205bc4d79 100644
--- a/gcc/ada/gen_il-internals.ads
+++ b/gcc/ada/gen_il-internals.ads
@@ -103,7 +103,11 @@ package Gen_IL.Internals is
-- a concrete type, First=Last. For an abstract type, First..Last
-- includes two or more types.
- Fields : Field_Vector;
+ Imm_Fields,
+ -- Fields declared immediately within a given node type
+ Fields :
+ -- Includes inherited fields and Imm_Fields
+ Field_Vector;
Nmake_Assert : String_Access; -- only for concrete node types
end case;
--
2.43.0
