URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
[/] [openrisc/] [trunk/] [gnu-stable/] [gcc-4.5.1/] [gcc/] [ada/] [sem_scil.adb] - Rev 826
Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S E M _ S C I L -- -- -- -- B o d y -- -- -- -- Copyright (C) 2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNAT; see file COPYING3. If not, go to -- -- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ 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; 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; 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; 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 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 P : Node_Id; -- Start of processing for Find_SCIL_Node 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) then return Found_Node; end if; end; end if; -- Otherwise climb up the tree searching for the SCIL node analyzing -- all the lists in which Insert_Actions may have inserted it P := Node; while Present (P) loop case Nkind (P) is -- Actions associated with AND THEN or OR ELSE when N_Short_Circuit => if Present (Actions (P)) and then Find_SCIL_Node (Actions (P)) then return Found_Node; end if; -- Actions of conditional expressions 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))) then return Found_Node; end if; -- Actions in handled sequence of statements when N_Handled_Sequence_Of_Statements => if Find_SCIL_Node (Statements (P)) then return Found_Node; end if; -- Conditions of while expression or elsif. 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; -- 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; -- 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. elsif Nkind (Parent (P)) = N_Component_Association then null; -- 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. elsif Nkind (Parent (P)) = N_Variant or else Nkind (Parent (P)) = N_Record_Definition then null; -- Otherwise search it in the list containing this node elsif Find_SCIL_Node (List_Containing (P)) then return Found_Node; end if; -- 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; -- 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_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_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; end case; -- If we fall through above tests, keep climbing tree if Nkind (Parent (P)) = N_Subunit then -- 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. P := Corresponding_Stub (Parent (P)); else P := Parent (P); end if; end loop; -- SCIL node not found return Empty; end Find_SCIL_Node; ------------------------- -- First_Non_SCIL_Node -- ------------------------- function First_Non_SCIL_Node (L : List_Id) return Node_Id is N : Node_Id; begin N := First (L); while Nkind (N) in N_SCIL_Node loop Next (N); end loop; return N; end First_Non_SCIL_Node; ------------------------ -- Next_Non_SCIL_Node -- ------------------------ function Next_Non_SCIL_Node (N : Node_Id) return Node_Id is Aux_N : Node_Id; begin Aux_N := Next (N); while Nkind (Aux_N) in N_SCIL_Node loop Next (Aux_N); end loop; return Aux_N; end Next_Non_SCIL_Node; end Sem_SCIL;