(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
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),
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),
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);
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),
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),
(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),
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);
(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,
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,
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
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;
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;
-- 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
-- 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
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;
-- 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
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:
"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
"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;
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
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
-- 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;
Check_Completeness;
- Compute_Ranges (Node_Kind);
- Compute_Ranges (Entity_Kind);
+ Compute_Ranges;
+ Inherit_Fields;
Compute_Fields_Per_Node;
Compute_Field_Offsets;
Compute_Type_Sizes;
projects / thirdparty / gcc.git / commitdiff
