-- --
------------------------------------------------------------------------------
-with Einfo; use Einfo;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Snames; use Snames;
-with Stand; use Stand;
+with Einfo; use Einfo;
+with Nlists; use Nlists;
+with Rtsfind; use Rtsfind;
+with Sem_Aux; use Sem_Aux;
+with Sinfo; use Sinfo;
+with Stand; use Stand;
+with SCIL_LL; use SCIL_LL;
package body Sem_SCIL is
- ----------------------
- -- Adjust_SCIL_Node --
- ----------------------
-
- procedure Adjust_SCIL_Node (Old_Node : Node_Id; New_Node : Node_Id) is
- SCIL_Node : Node_Id;
-
- begin
- pragma Assert (Generate_SCIL);
-
- -- Check cases in which no action is required. Currently the only SCIL
- -- nodes that may require adjustment are those of dispatching calls
- -- internally generated by the frontend.
-
- if Comes_From_Source (Old_Node)
- or else not
- Nkind_In (New_Node, N_Function_Call, N_Procedure_Call_Statement)
- then
- return;
-
- -- Conditional expression associated with equality operator. Old_Node
- -- may be part of the expansion of the predefined equality operator of
- -- a tagged type and hence we need to check if it has a SCIL dispatching
- -- node that needs adjustment.
-
- elsif Nkind (Old_Node) = N_Conditional_Expression
- and then (Nkind (Original_Node (Old_Node)) = N_Op_Eq
- or else
- (Nkind (Original_Node (Old_Node)) = N_Function_Call
- and then Chars (Name (Original_Node (Old_Node))) =
- Name_Op_Eq))
- then
- null;
-
- -- Type conversions may involve dispatching calls to functions whose
- -- associated SCIL dispatching node needs adjustment.
-
- elsif Nkind_In (Old_Node, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
- then
- null;
-
- -- Relocated subprogram call
-
- elsif Nkind (Old_Node) = Nkind (New_Node)
- and then Original_Node (Old_Node) = Original_Node (New_Node)
- then
- null;
-
- else
- return;
- end if;
-
- -- Search for the SCIL node and update it (if found)
-
- SCIL_Node := Find_SCIL_Node (Old_Node);
-
- if Present (SCIL_Node) then
- Set_SCIL_Related_Node (SCIL_Node, New_Node);
- end if;
- end Adjust_SCIL_Node;
-
---------------------
-- Check_SCIL_Node --
---------------------
function Check_SCIL_Node (N : Node_Id) return Traverse_Result is
- Ctrl_Tag : Node_Id;
- Ctrl_Typ : Entity_Id;
+ SCIL_Node : constant Node_Id := Get_SCIL_Node (N);
+ Ctrl_Tag : Node_Id;
+ Ctrl_Typ : Entity_Id;
begin
- if Nkind (N) = N_SCIL_Membership_Test then
-
- -- Check contents of the boolean expression associated with the
- -- membership test.
-
- pragma Assert (Nkind (SCIL_Related_Node (N)) = N_Identifier
- and then Etype (SCIL_Related_Node (N)) = Standard_Boolean);
-
- -- Check the entity identifier of the associated tagged type (that
- -- is, in testing for membership in T'Class, the entity id of the
- -- specific type T).
-
- -- Note: When the SCIL node is generated the private and full-view
- -- of the tagged types may have been swapped and hence the node
- -- referenced by attribute SCIL_Entity may be the private view.
- -- Therefore, in order to uniformily locate the full-view we use
- -- attribute Underlying_Type.
-
- pragma Assert (Is_Tagged_Type (Underlying_Type (SCIL_Entity (N))));
-
- -- Interface types are unsupported
-
- pragma Assert (not Is_Interface (Underlying_Type (SCIL_Entity (N))));
-
- -- Check the decoration of the expression that denotes the tag value
- -- being tested
-
- Ctrl_Tag := SCIL_Tag_Value (N);
-
- case Nkind (Ctrl_Tag) is
-
- -- For class-wide membership tests the SCIL tag value is the tag
- -- of the tested object (i.e. Obj.Tag).
-
- when N_Selected_Component =>
- pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag));
- null;
-
- when others =>
- pragma Assert (False);
- null;
- end case;
-
- return Skip;
+ -- For nodes that do not have SCIL node continue traversing the tree
- elsif Nkind (N) = N_SCIL_Dispatching_Call then
- Ctrl_Tag := SCIL_Controlling_Tag (N);
-
- -- SCIL_Related_Node of SCIL dispatching call nodes MUST reference
- -- subprogram calls.
-
- if not Nkind_In (SCIL_Related_Node (N), N_Function_Call,
- N_Procedure_Call_Statement)
- then
- pragma Assert (False);
- raise Program_Error;
-
- -- In simple cases the controlling tag is the tag of the controlling
- -- argument (i.e. Obj.Tag).
-
- elsif Nkind (Ctrl_Tag) = N_Selected_Component then
- Ctrl_Typ := Etype (Ctrl_Tag);
-
- -- Interface types are unsupported
-
- if Is_Interface (Ctrl_Typ)
- or else (RTE_Available (RE_Interface_Tag)
- and then Ctrl_Typ = RTE (RE_Interface_Tag))
- then
- null;
-
- else
- pragma Assert (Ctrl_Typ = RTE (RE_Tag));
- null;
- end if;
-
- -- When the controlling tag of a dispatching call is an identifier
- -- the SCIL_Controlling_Tag attribute references the corresponding
- -- object or parameter declaration. Interface types are still
- -- unsupported.
-
- elsif Nkind_In (Ctrl_Tag, N_Object_Declaration,
- N_Parameter_Specification)
- then
- Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag));
-
- -- Interface types are unsupported.
-
- if Is_Interface (Ctrl_Typ)
- or else (RTE_Available (RE_Interface_Tag)
- and then Ctrl_Typ = RTE (RE_Interface_Tag))
- or else (Is_Access_Type (Ctrl_Typ)
- and then
- Is_Interface
- (Available_View
- (Base_Type (Designated_Type (Ctrl_Typ)))))
- then
- null;
-
- else
- pragma Assert
- (Ctrl_Typ = RTE (RE_Tag)
- or else
- (Is_Access_Type (Ctrl_Typ)
- and then Available_View
- (Base_Type (Designated_Type (Ctrl_Typ))) =
- RTE (RE_Tag)));
- null;
- end if;
-
- -- Interface types are unsupported
-
- elsif Is_Interface (Etype (Ctrl_Tag)) then
- null;
-
- else
- pragma Assert (False);
- raise Program_Error;
- end if;
-
- return Skip;
-
- -- Node is not N_SCIL_Dispatching_Call
-
- else
+ if No (SCIL_Node) then
return OK;
end if;
- end Check_SCIL_Node;
- --------------------
- -- Find_SCIL_Node --
- --------------------
-
- function Find_SCIL_Node (Node : Node_Id) return Node_Id is
- Found_Node : Node_Id;
- -- This variable stores the last node found by the nested subprogram
- -- Find_SCIL_Node.
-
- function Find_SCIL_Node (L : List_Id) return Boolean;
- -- Searches in list L for a SCIL node associated with a dispatching call
- -- whose SCIL_Related_Node is Node. If found returns true and stores the
- -- SCIL node in Found_Node; otherwise returns False and sets Found_Node
- -- to Empty.
-
- --------------------
- -- Find_SCIL_Node --
- --------------------
-
- function Find_SCIL_Node (L : List_Id) return Boolean is
- N : Node_Id;
-
- begin
- N := First (L);
- while Present (N) loop
- if Nkind (N) in N_SCIL_Node
- and then SCIL_Related_Node (N) = Node
- then
- Found_Node := N;
- return True;
- end if;
-
- Next (N);
- end loop;
-
- Found_Node := Empty;
- return False;
- end Find_SCIL_Node;
-
- -- Local variables
+ case Nkind (SCIL_Node) is
+ when N_SCIL_Dispatch_Table_Tag_Init =>
+ pragma Assert (Nkind (N) = N_Object_Declaration);
+ null;
- P : Node_Id;
+ when N_SCIL_Dispatching_Call =>
+ Ctrl_Tag := SCIL_Controlling_Tag (SCIL_Node);
- -- Start of processing for Find_SCIL_Node
+ -- Parent of SCIL dispatching call nodes MUST be a subprogram call
- begin
- pragma Assert (Generate_SCIL);
-
- -- Search for the SCIL node in list associated with a transient scope
-
- if Scope_Is_Transient then
- declare
- SE : Scope_Stack_Entry
- renames Scope_Stack.Table (Scope_Stack.Last);
- begin
- if SE.Is_Transient
- and then Present (SE.Actions_To_Be_Wrapped_Before)
- and then Find_SCIL_Node (SE.Actions_To_Be_Wrapped_Before)
+ if not Nkind_In (N, N_Function_Call,
+ N_Procedure_Call_Statement)
then
- return Found_Node;
- end if;
- end;
- end if;
+ pragma Assert (False);
+ raise Program_Error;
- -- Otherwise climb up the tree searching for the SCIL node analyzing
- -- all the lists in which Insert_Actions may have inserted it
+ -- In simple cases the controlling tag is the tag of the
+ -- controlling argument (i.e. Obj.Tag).
- P := Node;
- while Present (P) loop
- case Nkind (P) is
+ elsif Nkind (Ctrl_Tag) = N_Selected_Component then
+ Ctrl_Typ := Etype (Ctrl_Tag);
- -- Actions associated with AND THEN or OR ELSE
+ -- Interface types are unsupported
- when N_Short_Circuit =>
- if Present (Actions (P))
- and then Find_SCIL_Node (Actions (P))
+ if Is_Interface (Ctrl_Typ)
+ or else (RTE_Available (RE_Interface_Tag)
+ and then Ctrl_Typ = RTE (RE_Interface_Tag))
then
- return Found_Node;
- end if;
-
- -- Actions of case expressions
+ null;
- when N_Case_Expression_Alternative =>
- if Present (Actions (P))
- and then Find_SCIL_Node (Actions (P))
- then
- return Found_Node;
+ else
+ pragma Assert (Ctrl_Typ = RTE (RE_Tag));
+ null;
end if;
- -- Actions of conditional expressions
+ -- When the controlling tag of a dispatching call is an identifier
+ -- the SCIL_Controlling_Tag attribute references the corresponding
+ -- object or parameter declaration. Interface types are still
+ -- unsupported.
- when N_Conditional_Expression =>
- if (Present (Then_Actions (P))
- and then Find_SCIL_Node (Actions (P)))
- or else
- (Present (Else_Actions (P))
- and then Find_SCIL_Node (Else_Actions (P)))
+ elsif Nkind_In (Ctrl_Tag, N_Object_Declaration,
+ N_Parameter_Specification)
+ then
+ Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag));
+
+ -- Interface types are unsupported.
+
+ if Is_Interface (Ctrl_Typ)
+ or else (RTE_Available (RE_Interface_Tag)
+ and then Ctrl_Typ = RTE (RE_Interface_Tag))
+ or else (Is_Access_Type (Ctrl_Typ)
+ and then
+ Is_Interface
+ (Available_View
+ (Base_Type (Designated_Type (Ctrl_Typ)))))
then
- return Found_Node;
+ null;
+
+ else
+ pragma Assert
+ (Ctrl_Typ = RTE (RE_Tag)
+ or else
+ (Is_Access_Type (Ctrl_Typ)
+ and then Available_View
+ (Base_Type (Designated_Type (Ctrl_Typ)))
+ = RTE (RE_Tag)));
+ null;
end if;
- -- Actions in handled sequence of statements
+ -- Interface types are unsupported
- when
- N_Handled_Sequence_Of_Statements =>
- if Find_SCIL_Node (Statements (P)) then
- return Found_Node;
- end if;
+ elsif Is_Interface (Etype (Ctrl_Tag)) then
+ null;
- -- Conditions of while expression or elsif.
+ else
+ pragma Assert (False);
+ raise Program_Error;
+ end if;
- when N_Iteration_Scheme |
- N_Elsif_Part
- =>
- if Present (Condition_Actions (P))
- and then Find_SCIL_Node (Condition_Actions (P))
- then
- return Found_Node;
- end if;
+ return Skip;
- -- Statements, declarations, pragmas, representation clauses
-
- when
- -- Statements
-
- N_Procedure_Call_Statement |
- N_Statement_Other_Than_Procedure_Call |
-
- -- Pragmas
-
- N_Pragma |
-
- -- Representation_Clause
-
- N_At_Clause |
- N_Attribute_Definition_Clause |
- N_Enumeration_Representation_Clause |
- N_Record_Representation_Clause |
-
- -- Declarations
-
- N_Abstract_Subprogram_Declaration |
- N_Entry_Body |
- N_Exception_Declaration |
- N_Exception_Renaming_Declaration |
- N_Formal_Abstract_Subprogram_Declaration |
- N_Formal_Concrete_Subprogram_Declaration |
- N_Formal_Object_Declaration |
- N_Formal_Type_Declaration |
- N_Full_Type_Declaration |
- N_Function_Instantiation |
- N_Generic_Function_Renaming_Declaration |
- N_Generic_Package_Declaration |
- N_Generic_Package_Renaming_Declaration |
- N_Generic_Procedure_Renaming_Declaration |
- N_Generic_Subprogram_Declaration |
- N_Implicit_Label_Declaration |
- N_Incomplete_Type_Declaration |
- N_Number_Declaration |
- N_Object_Declaration |
- N_Object_Renaming_Declaration |
- N_Package_Body |
- N_Package_Body_Stub |
- N_Package_Declaration |
- N_Package_Instantiation |
- N_Package_Renaming_Declaration |
- N_Private_Extension_Declaration |
- N_Private_Type_Declaration |
- N_Procedure_Instantiation |
- N_Protected_Body |
- N_Protected_Body_Stub |
- N_Protected_Type_Declaration |
- N_Single_Task_Declaration |
- N_Subprogram_Body |
- N_Subprogram_Body_Stub |
- N_Subprogram_Declaration |
- N_Subprogram_Renaming_Declaration |
- N_Subtype_Declaration |
- N_Task_Body |
- N_Task_Body_Stub |
- N_Task_Type_Declaration |
-
- -- Freeze entity behaves like a declaration or statement
-
- N_Freeze_Entity
- =>
- -- Do not search here if the item is not a list member
-
- if not Is_List_Member (P) then
- null;
+ when N_SCIL_Membership_Test =>
- -- Do not search if parent of P is an N_Component_Association
- -- node (i.e. we are in the context of an N_Aggregate or
- -- N_Extension_Aggregate node). In this case the node should
- -- have been added before the entire aggregate.
+ -- Check contents of the boolean expression associated with the
+ -- membership test.
- elsif Nkind (Parent (P)) = N_Component_Association then
- null;
+ pragma Assert (Nkind_In (N, N_Identifier,
+ N_And_Then,
+ N_Or_Else,
+ N_Expression_With_Actions)
+ and then Etype (N) = Standard_Boolean);
- -- Do not search if the parent of P is either an N_Variant
- -- node or an N_Record_Definition node. In this case the node
- -- should have been added before the entire record.
+ -- Check the entity identifier of the associated tagged type (that
+ -- is, in testing for membership in T'Class, the entity id of the
+ -- specific type T).
- elsif Nkind (Parent (P)) = N_Variant
- or else Nkind (Parent (P)) = N_Record_Definition
- then
- null;
+ -- Note: When the SCIL node is generated the private and full-view
+ -- of the tagged types may have been swapped and hence the node
+ -- referenced by attribute SCIL_Entity may be the private view.
+ -- Therefore, in order to uniformily locate the full-view we use
+ -- attribute Underlying_Type.
- -- Otherwise search it in the list containing this node
+ pragma Assert
+ (Is_Tagged_Type (Underlying_Type (SCIL_Entity (SCIL_Node))));
- elsif Find_SCIL_Node (List_Containing (P)) then
- return Found_Node;
- end if;
+ -- Interface types are unsupported
- -- A special case, N_Raise_xxx_Error can act either as a statement
- -- or a subexpression. We diferentiate them by looking at the
- -- Etype. It is set to Standard_Void_Type in the statement case.
-
- when
- N_Raise_xxx_Error =>
- if Etype (P) = Standard_Void_Type then
- if Is_List_Member (P)
- and then Find_SCIL_Node (List_Containing (P))
- then
- return Found_Node;
- end if;
-
- -- In the subexpression case, keep climbing
-
- else
- null;
- end if;
-
- -- If a component association appears within a loop created for
- -- an array aggregate, check if the SCIL node was added to the
- -- the list of nodes attached to the association.
-
- when
- N_Component_Association =>
- if Nkind (Parent (P)) = N_Aggregate
- and then Present (Loop_Actions (P))
- and then Find_SCIL_Node (Loop_Actions (P))
- then
- return Found_Node;
- end if;
-
- -- Another special case, an attribute denoting a procedure call
-
- when
- N_Attribute_Reference =>
- if Is_Procedure_Attribute_Name (Attribute_Name (P))
- and then Find_SCIL_Node (List_Containing (P))
- then
- return Found_Node;
-
- -- In the subexpression case keep climbing
-
- else
- null;
- end if;
-
- -- SCIL nodes do not have subtrees and hence they can never be
- -- found climbing tree
-
- when
- N_SCIL_Dispatch_Table_Object_Init |
- N_SCIL_Dispatch_Table_Tag_Init |
- N_SCIL_Dispatching_Call |
- N_SCIL_Membership_Test |
- N_SCIL_Tag_Init
- =>
- pragma Assert (False);
- raise Program_Error;
+ pragma Assert
+ (not Is_Interface (Underlying_Type (SCIL_Entity (SCIL_Node))));
- -- For all other node types, keep climbing tree
-
- when
- N_Abortable_Part |
- N_Accept_Alternative |
- N_Access_Definition |
- N_Access_Function_Definition |
- N_Access_Procedure_Definition |
- N_Access_To_Object_Definition |
- N_Aggregate |
- N_Allocator |
- N_Case_Expression |
- N_Case_Statement_Alternative |
- N_Character_Literal |
- N_Compilation_Unit |
- N_Compilation_Unit_Aux |
- N_Component_Clause |
- N_Component_Declaration |
- N_Component_Definition |
- N_Component_List |
- N_Constrained_Array_Definition |
- N_Decimal_Fixed_Point_Definition |
- N_Defining_Character_Literal |
- N_Defining_Identifier |
- N_Defining_Operator_Symbol |
- N_Defining_Program_Unit_Name |
- N_Delay_Alternative |
- N_Delta_Constraint |
- N_Derived_Type_Definition |
- N_Designator |
- N_Digits_Constraint |
- N_Discriminant_Association |
- N_Discriminant_Specification |
- N_Empty |
- N_Entry_Body_Formal_Part |
- N_Entry_Call_Alternative |
- N_Entry_Declaration |
- N_Entry_Index_Specification |
- N_Enumeration_Type_Definition |
- N_Error |
- N_Exception_Handler |
- N_Expanded_Name |
- N_Explicit_Dereference |
- N_Expression_With_Actions |
- N_Extension_Aggregate |
- N_Floating_Point_Definition |
- N_Formal_Decimal_Fixed_Point_Definition |
- N_Formal_Derived_Type_Definition |
- N_Formal_Discrete_Type_Definition |
- N_Formal_Floating_Point_Definition |
- N_Formal_Modular_Type_Definition |
- N_Formal_Ordinary_Fixed_Point_Definition |
- N_Formal_Package_Declaration |
- N_Formal_Private_Type_Definition |
- N_Formal_Signed_Integer_Type_Definition |
- N_Function_Call |
- N_Function_Specification |
- N_Generic_Association |
- N_Identifier |
- N_In |
- N_Index_Or_Discriminant_Constraint |
- N_Indexed_Component |
- N_Integer_Literal |
- N_Itype_Reference |
- N_Label |
- N_Loop_Parameter_Specification |
- N_Mod_Clause |
- N_Modular_Type_Definition |
- N_Not_In |
- N_Null |
- N_Op_Abs |
- N_Op_Add |
- N_Op_And |
- N_Op_Concat |
- N_Op_Divide |
- N_Op_Eq |
- N_Op_Expon |
- N_Op_Ge |
- N_Op_Gt |
- N_Op_Le |
- N_Op_Lt |
- N_Op_Minus |
- N_Op_Mod |
- N_Op_Multiply |
- N_Op_Ne |
- N_Op_Not |
- N_Op_Or |
- N_Op_Plus |
- N_Op_Rem |
- N_Op_Rotate_Left |
- N_Op_Rotate_Right |
- N_Op_Shift_Left |
- N_Op_Shift_Right |
- N_Op_Shift_Right_Arithmetic |
- N_Op_Subtract |
- N_Op_Xor |
- N_Operator_Symbol |
- N_Ordinary_Fixed_Point_Definition |
- N_Others_Choice |
- N_Package_Specification |
- N_Parameter_Association |
- N_Parameter_Specification |
- N_Pop_Constraint_Error_Label |
- N_Pop_Program_Error_Label |
- N_Pop_Storage_Error_Label |
- N_Pragma_Argument_Association |
- N_Procedure_Specification |
- N_Protected_Definition |
- N_Push_Constraint_Error_Label |
- N_Push_Program_Error_Label |
- N_Push_Storage_Error_Label |
- N_Qualified_Expression |
- N_Range |
- N_Range_Constraint |
- N_Real_Literal |
- N_Real_Range_Specification |
- N_Record_Definition |
- N_Reference |
- N_Selected_Component |
- N_Signed_Integer_Type_Definition |
- N_Single_Protected_Declaration |
- N_Slice |
- N_String_Literal |
- N_Subprogram_Info |
- N_Subtype_Indication |
- N_Subunit |
- N_Task_Definition |
- N_Terminate_Alternative |
- N_Triggering_Alternative |
- N_Type_Conversion |
- N_Unchecked_Expression |
- N_Unchecked_Type_Conversion |
- N_Unconstrained_Array_Definition |
- N_Unused_At_End |
- N_Unused_At_Start |
- N_Use_Package_Clause |
- N_Use_Type_Clause |
- N_Variant |
- N_Variant_Part |
- N_Validate_Unchecked_Conversion |
- N_With_Clause
- =>
- null;
+ -- Check the decoration of the expression that denotes the tag
+ -- value being tested
- end case;
+ Ctrl_Tag := SCIL_Tag_Value (SCIL_Node);
- -- If we fall through above tests keep climbing tree
+ case Nkind (Ctrl_Tag) is
- if Nkind (Parent (P)) = N_Subunit then
+ -- For class-wide membership tests the SCIL tag value is the
+ -- tag of the tested object (i.e. Obj.Tag).
- -- This is the proper body corresponding to a stub. Insertion done
- -- at the point of the stub, which is in the declarative part of
- -- the parent unit.
+ when N_Selected_Component =>
+ pragma Assert (Etype (Ctrl_Tag) = RTE (RE_Tag));
+ null;
- P := Corresponding_Stub (Parent (P));
+ when others =>
+ pragma Assert (False);
+ null;
+ end case;
- else
- P := Parent (P);
- end if;
- end loop;
+ return Skip;
- -- SCIL node not found
+ when others =>
+ pragma Assert (False);
+ raise Program_Error;
+ end case;
- return Empty;
- end Find_SCIL_Node;
+ return Skip;
+ end Check_SCIL_Node;
-------------------------
-- First_Non_SCIL_Node --
OSDN Git Service
