From: charlet Date: Tue, 28 Jul 2009 08:46:39 +0000 (+0000) Subject: 2009-07-28 Javier Miranda X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=d215f619b3633b756b36e9f31b2f786844e08463;p=thirdparty%2Fgcc.git 2009-07-28 Javier Miranda * gnat1drv.adb (Adjust_Global_Switches): Disable generation of SCIL nodes if we are not generating code. * frontend.adb (Check_SCIL_Node): New subprogram. Used to check attribute SCIL_Related_Node of SCIL dispatching nodes. (Check_SCIL_Nodes): New instantiation of Traverse_Proc. * sinfo.ads (Is_SCIL_Node,Set_Is_SCIL_Node): Removed (SCIL_Nkind,Set_SCIL_Nkind): Removed. (SCIL_Entity): Update documentation. (SCIL_Related_Node): Update documentation. (SCIL_Controlling_Tag): New attribute. (SCIL_Target_Prim): Update documentation. (N_Null_Statement): Remove attributes associated with SCIL nodes. (N_SCIL_Dispatch_Table_Object_Init): New node. (N_SCIL_Dispatch_Table_Tag_Init): New node. (N_SCIL_Dispatching_Call): New node. (N_SCIL_Tag_Init): New node. * sinfo.adb (Is_SCIL_Node,Set_Is_SCIL_Node): Removed (SCIL_Nkind,Set_SCIL_Nkind): Removed. (SCIL_Controlling_Tag/Set_SCIL_Controlling_Tag): New subprogram. (SCIL_Entity,Set_SCIL_Entity): Applicable only to SCIL nodes. (SCIL_Related_Node,Set_SCIL_Related_Node): Applicable only to SCIL nodes (SCIL_Target_Prim,Set_SCIL_Target_Prim): Applicable only to N_SCIL_Dispatching_Call nodes. * sem.adb (Analyze): No need to analyze SCIL nodes. * sem_aux.ads, sem_aux.adb (First_Non_SCIL_Node): New subprogram (Next_Non_SCIL_Node): New subprogram * sem_ch4.adb (Analyze_Type_Conversion): Adjust relocated SCIL dispatching nodes. * sem_ch5.adb (Analyze_Iteration_Scheme): Adjust relocated SCIL dispatching node. * sem_util.adb (Insert_Explicit_Dereference): Adjust relocated SCIL dispatching node. * exp_ch3.adb (Build_Array_Init_Proc): Skip SCIL nodes when processing null statement nodes. (Build_Init_Procedure): Generate new SCIL node. * exp_ch4.adb (Expand_N_And_Then): Adjust relocated SCIL dispatching node. * exp_ch6.adb (Is_Null_Procedure): Skip SCIL nodes. Required because they are currently implemented as special N_Null_Statement nodes. * exp_ch7.adb (Wrap_Transient_Statement): If the relocated node is a procedure call then check if some SCIL node references it and needs readjustment. * exp_disp.ads (SCIL_Node_Kind): Removed. (Adjust_SCIL_Node): New subprogram. (Find_SCIL_Node): New subprogram. (Get_SCIL_Node_Kind): Removed. (New_SCIL_Node): Removed. * exp_disp.adb (Adjust_SCIL_Node): New subprogram (Expand_Dispatching_Call): Generate new SCIL dispatching node including decoration of its new controlling_tag attribute. (Get_SCIL_Node_Kind): Removed. (Find_SCIL_Node): New subprogram. (Make_Secondary_DT): Generate new SCIL nodes. (Make_Tags): Generate new SCIL nodes. (New_SCIL_Node): Removed. * exp_util.adb (Insert_Actions): Handle SCIL nodes. (Remove_Side_Effects): Check if relocated nodes require readjustment of some SCIL dispatching node. * gcc-interface/trans.c (gnat_to_gnu): Do nothing with new SCIL nodes. git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@150149 138bc75d-0d04-0410-961f-82ee72b054a4 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a8df54326293..0fe4ef446242 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,65 @@ +2009-07-28 Javier Miranda + + * gnat1drv.adb (Adjust_Global_Switches): Disable generation of SCIL + nodes if we are not generating code. + * frontend.adb (Check_SCIL_Node): New subprogram. Used to check + attribute SCIL_Related_Node of SCIL dispatching nodes. + (Check_SCIL_Nodes): New instantiation of Traverse_Proc. + * sinfo.ads (Is_SCIL_Node,Set_Is_SCIL_Node): Removed + (SCIL_Nkind,Set_SCIL_Nkind): Removed. + (SCIL_Entity): Update documentation. + (SCIL_Related_Node): Update documentation. + (SCIL_Controlling_Tag): New attribute. + (SCIL_Target_Prim): Update documentation. + (N_Null_Statement): Remove attributes associated with SCIL nodes. + (N_SCIL_Dispatch_Table_Object_Init): New node. + (N_SCIL_Dispatch_Table_Tag_Init): New node. + (N_SCIL_Dispatching_Call): New node. + (N_SCIL_Tag_Init): New node. + * sinfo.adb (Is_SCIL_Node,Set_Is_SCIL_Node): Removed + (SCIL_Nkind,Set_SCIL_Nkind): Removed. + (SCIL_Controlling_Tag/Set_SCIL_Controlling_Tag): New subprogram. + (SCIL_Entity,Set_SCIL_Entity): Applicable only to SCIL nodes. + (SCIL_Related_Node,Set_SCIL_Related_Node): Applicable only to SCIL nodes + (SCIL_Target_Prim,Set_SCIL_Target_Prim): Applicable only to + N_SCIL_Dispatching_Call nodes. + * sem.adb (Analyze): No need to analyze SCIL nodes. + * sem_aux.ads, sem_aux.adb (First_Non_SCIL_Node): New subprogram + (Next_Non_SCIL_Node): New subprogram + * sem_ch4.adb (Analyze_Type_Conversion): Adjust relocated SCIL + dispatching nodes. + * sem_ch5.adb (Analyze_Iteration_Scheme): Adjust relocated SCIL + dispatching node. + * sem_util.adb (Insert_Explicit_Dereference): Adjust relocated SCIL + dispatching node. + * exp_ch3.adb (Build_Array_Init_Proc): Skip SCIL nodes when processing + null statement nodes. + (Build_Init_Procedure): Generate new SCIL node. + * exp_ch4.adb (Expand_N_And_Then): Adjust relocated SCIL dispatching + node. + * exp_ch6.adb (Is_Null_Procedure): Skip SCIL nodes. Required because + they are currently implemented as special N_Null_Statement nodes. + * exp_ch7.adb (Wrap_Transient_Statement): If the relocated node is a + procedure call then check if some SCIL node references it and needs + readjustment. + * exp_disp.ads (SCIL_Node_Kind): Removed. + (Adjust_SCIL_Node): New subprogram. + (Find_SCIL_Node): New subprogram. + (Get_SCIL_Node_Kind): Removed. + (New_SCIL_Node): Removed. + * exp_disp.adb (Adjust_SCIL_Node): New subprogram + (Expand_Dispatching_Call): Generate new SCIL dispatching node including + decoration of its new controlling_tag attribute. + (Get_SCIL_Node_Kind): Removed. + (Find_SCIL_Node): New subprogram. + (Make_Secondary_DT): Generate new SCIL nodes. + (Make_Tags): Generate new SCIL nodes. + (New_SCIL_Node): Removed. + * exp_util.adb (Insert_Actions): Handle SCIL nodes. + (Remove_Side_Effects): Check if relocated nodes require readjustment + of some SCIL dispatching node. + * gcc-interface/trans.c (gnat_to_gnu): Do nothing with new SCIL nodes. + 2009-07-28 Robert Dewar * prj-nmsc.adb, g-expect.adb, prj.ads: Minor reformatting diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index e8b46e55e609..4ff1f3e12dad 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -752,7 +752,11 @@ package body Exp_Ch3 is Set_Init_Proc (A_Type, Proc_Id); if List_Length (Body_Stmts) = 1 - and then Nkind (First (Body_Stmts)) = N_Null_Statement + + -- We must skip SCIL nodes because they may have been added to this + -- list by Insert_Actions. + + and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement then Set_Is_Null_Init_Proc (Proc_Id); @@ -763,7 +767,7 @@ package body Exp_Ch3 is Set_Static_Initialization (Proc_Id, - Build_Equivalent_Array_Aggregate (First_Subtype (A_Type))); + Build_Equivalent_Array_Aggregate (First_Subtype (A_Type))); end if; end if; end Build_Array_Init_Proc; @@ -1939,6 +1943,7 @@ package body Exp_Ch3 is D := First_Discriminant (Rec_Type); while Present (D) loop + -- Don't generate the assignment for discriminants in derived -- tagged types if the discriminant is a renaming of some -- ancestor discriminant. This initialization will be done @@ -2330,11 +2335,16 @@ package body Exp_Ch3 is -- the tag component. if Generate_SCIL then - Prepend_To (Init_Tags_List, - New_SCIL_Node - (SN_Kind => IP_Tag_Init, - Related_Node => First (Init_Tags_List), - Entity => Rec_Type)); + declare + New_Node : Node_Id; + + begin + New_Node := + Make_SCIL_Tag_Init (Sloc (First (Init_Tags_List))); + Set_SCIL_Related_Node (New_Node, First (Init_Tags_List)); + Set_SCIL_Entity (New_Node, Rec_Type); + Prepend_To (Init_Tags_List, New_Node); + end; end if; -- Ada 2005 (AI-251): Initialize the secondary tags components @@ -2496,7 +2506,11 @@ package body Exp_Ch3 is Set_Init_Proc (Rec_Type, Proc_Id); if List_Length (Body_Stmts) = 1 - and then Nkind (First (Body_Stmts)) = N_Null_Statement + + -- We must skip SCIL nodes because they are currently implemented + -- as special N_Null_Statement nodes. + + and then Nkind (First_Non_SCIL_Node (Body_Stmts)) = N_Null_Statement and then VM_Target = No_VM then -- Even though the init proc may be null at this time it might get diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 258ce3a82669..167582374fb0 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -3965,6 +3965,16 @@ package body Exp_Ch4 is Right, New_Occurrence_Of (Standard_False, Loc)))); + -- If the right part of the expression is a function call then it can + -- be part of the expansion of the predefined equality operator of a + -- tagged type and we may need to adjust its SCIL dispatching node. + + if Generate_SCIL + and then Nkind (Right) = N_Function_Call + then + Adjust_SCIL_Node (N, Right); + end if; + Set_Then_Actions (N, Actlist); Analyze_And_Resolve (N, Standard_Boolean); Adjust_Result_Type (N, Typ); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index c326916476ce..13f6d9d0a1d7 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -4972,10 +4972,13 @@ package body Exp_Ch6 is if Nkind (Orig_Bod) /= N_Subprogram_Body then return False; else + -- We must skip SCIL nodes because they are currently + -- implemented as special N_Null_Statement nodes. + Stat := - First + First_Non_SCIL_Node (Statements (Handled_Statement_Sequence (Orig_Bod))); - Stat2 := Next (Stat); + Stat2 := Next_Non_SCIL_Node (Stat); return Is_Empty_List (Declarations (Orig_Bod)) diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index a8a32fb5114b..28704052c29d 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -3602,6 +3602,15 @@ package body Exp_Ch7 is New_Statement : constant Node_Id := Relocate_Node (N); begin + -- If the relocated node is a procedure call then check if some SCIL + -- node references it and needs readjustment. + + if Generate_SCIL + and then Nkind (New_Statement) = N_Procedure_Call_Statement + then + Adjust_SCIL_Node (N, New_Statement); + end if; + Rewrite (N, Make_Transient_Block (Loc, New_Statement)); -- With the scope stack back to normal, we can call analyze on the diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 761a113ab855..634d7647c39a 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -100,6 +100,66 @@ package body Exp_Disp is -- Ada 2005 (AI-345): Determine the tagged kind of T and return a reference -- to an RE_Tagged_Kind enumeration value. + ---------------------- + -- 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 (Old_Node) = N_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; + ---------------------- -- Apply_Tag_Checks -- ---------------------- @@ -575,6 +635,10 @@ package body Exp_Disp is end if; end New_Value; + -- Local variables + + SCIL_Node : Node_Id; + -- Start of processing for Expand_Dispatching_Call begin @@ -649,12 +713,11 @@ package body Exp_Disp is -- BEFORE the expanded nodes associated with the call node are found. if Generate_SCIL then - Insert_Action (Call_Node, - New_SCIL_Node - (SN_Kind => Dispatching_Call, - Related_Node => Call_Node, - Entity => Typ, - Target_Prim => Subp)); + SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node)); + Set_SCIL_Related_Node (SCIL_Node, Call_Node); + Set_SCIL_Entity (SCIL_Node, Typ); + Set_SCIL_Target_Prim (SCIL_Node, Subp); + Insert_Action (Call_Node, SCIL_Node); end if; if not Is_Limited_Type (Typ) then @@ -811,6 +874,12 @@ package body Exp_Disp is Selector_Name => New_Reference_To (DTC_Entity (Subp), Loc)); end if; + -- Complete decoration of SCIL dispatching node + + if Generate_SCIL then + Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag); + end if; + -- Handle dispatching calls to predefined primitives if Is_Predefined_Dispatching_Operation (Subp) @@ -1610,16 +1679,424 @@ package body Exp_Disp is end if; end Expand_Interface_Thunk; - ------------------------ - -- Get_SCIL_Node_Kind -- - ------------------------ + -------------------- + -- 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. + + 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 - function Get_SCIL_Node_Kind (Node : Node_Id) return SCIL_Node_Kind is begin - pragma Assert - (Nkind (Node) = N_Null_Statement and then Is_SCIL_Node (Node)); - return SCIL_Node_Kind'Val (UI_To_Int (SCIL_Nkind (Node))); - end Get_SCIL_Node_Kind; + pragma Assert (Generate_SCIL); + + -- Search for the SCIL node in the 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; + + -- 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_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_Handled_Sequence_Of_Statements | + 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; ------------ -- Has_DT -- @@ -4250,11 +4727,11 @@ package body Exp_Disp is -- because it has a null dispatch table. if Generate_SCIL then - Insert_Before (Last (Result), - New_SCIL_Node - (SN_Kind => Dispatch_Table_Object_Init, - Related_Node => Last (Result), - Entity => Typ)); + New_Node := + Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); + Set_SCIL_Related_Node (New_Node, Last (Result)); + Set_SCIL_Entity (New_Node, Typ); + Insert_Before (Last (Result), New_Node); end if; Append_To (Result, @@ -4287,11 +4764,11 @@ package body Exp_Disp is -- because it has a tag initialization. if Generate_SCIL then - Insert_Before (Last (Result), - New_SCIL_Node - (SN_Kind => Dispatch_Table_Tag_Init, - Related_Node => Last (Result), - Entity => Typ)); + New_Node := + Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); + Set_SCIL_Related_Node (New_Node, Last (Result)); + Set_SCIL_Entity (New_Node, Typ); + Insert_Before (Last (Result), New_Node); end if; -- Generate: @@ -4327,11 +4804,11 @@ package body Exp_Disp is -- because it contains a dispatch table. if Generate_SCIL then - Insert_Before (Last (Result), - New_SCIL_Node - (SN_Kind => Dispatch_Table_Object_Init, - Related_Node => Last (Result), - Entity => Typ)); + New_Node := + Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); + Set_SCIL_Related_Node (New_Node, Last (Result)); + Set_SCIL_Entity (New_Node, Typ); + Insert_Before (Last (Result), New_Node); end if; Append_To (Result, @@ -4364,11 +4841,11 @@ package body Exp_Disp is -- because it has a tag initialization. if Generate_SCIL then - Insert_Before (Last (Result), - New_SCIL_Node - (SN_Kind => Dispatch_Table_Tag_Init, - Related_Node => Last (Result), - Entity => Typ)); + New_Node := + Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); + Set_SCIL_Related_Node (New_Node, Last (Result)); + Set_SCIL_Entity (New_Node, Typ); + Insert_Before (Last (Result), New_Node); end if; Append_To (Result, @@ -5143,11 +5620,11 @@ package body Exp_Disp is -- because it has a null dispatch table. if Generate_SCIL then - Insert_Before (Last (Result), - New_SCIL_Node - (SN_Kind => Dispatch_Table_Object_Init, - Related_Node => Last (Result), - Entity => Typ)); + New_Node := + Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); + Set_SCIL_Related_Node (New_Node, Last (Result)); + Set_SCIL_Entity (New_Node, Typ); + Insert_Before (Last (Result), New_Node); end if; Append_To (Result, @@ -5460,11 +5937,11 @@ package body Exp_Disp is -- because it contains a dispatch table. if Generate_SCIL then - Insert_Before (Last (Result), - New_SCIL_Node - (SN_Kind => Dispatch_Table_Object_Init, - Related_Node => Last (Result), - Entity => Typ)); + New_Node := + Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); + Set_SCIL_Related_Node (New_Node, Last (Result)); + Set_SCIL_Entity (New_Node, Typ); + Insert_Before (Last (Result), New_Node); end if; Append_To (Result, @@ -6098,6 +6575,7 @@ package body Exp_Disp is Predef_Prims_Ptr : Node_Id; Iface_DT : Node_Id; Iface_DT_Ptr : Node_Id; + New_Node : Node_Id; Suffix_Index : Int; Typ_Name : Name_Id; Typ_Comps : Elist_Id; @@ -6161,11 +6639,11 @@ package body Exp_Disp is -- because it has a tag initialization. if Generate_SCIL then - Insert_Before (Last (Result), - New_SCIL_Node - (SN_Kind => Dispatch_Table_Tag_Init, - Related_Node => Last (Result), - Entity => Typ)); + New_Node := + Make_SCIL_Dispatch_Table_Tag_Init (Sloc (Last (Result))); + Set_SCIL_Related_Node (New_Node, Last (Result)); + Set_SCIL_Entity (New_Node, Typ); + Insert_Before (Last (Result), New_Node); end if; Append_To (Result, @@ -6207,11 +6685,11 @@ package body Exp_Disp is -- because it has a tag initialization. if Generate_SCIL then - Insert_Before (Last (Result), - New_SCIL_Node - (SN_Kind => Dispatch_Table_Tag_Init, - Related_Node => Last (Result), - Entity => Typ)); + New_Node := + Make_SCIL_Dispatch_Table_Object_Init (Sloc (Last (Result))); + Set_SCIL_Related_Node (New_Node, Last (Result)); + Set_SCIL_Entity (New_Node, Typ); + Insert_Before (Last (Result), New_Node); end if; end if; @@ -6436,29 +6914,6 @@ package body Exp_Disp is end if; end New_Value; - ------------------- - -- New_SCIL_Node -- - ------------------- - - function New_SCIL_Node - (SN_Kind : SCIL_Node_Kind; - Related_Node : Node_Id; - Entity : Entity_Id := Empty; - Target_Prim : Entity_Id := Empty) return Node_Id - is - New_N : constant Node_Id := - New_Node (N_Null_Statement, Sloc (Related_Node)); - begin - Set_Is_SCIL_Node (New_N); - - Set_SCIL_Nkind (New_N, UI_From_Int (SCIL_Node_Kind'Pos (SN_Kind))); - Set_SCIL_Related_Node (New_N, Related_Node); - Set_SCIL_Entity (New_N, Entity); - Set_SCIL_Target_Prim (New_N, Target_Prim); - - return New_N; - end New_SCIL_Node; - ----------------------------------- -- Original_View_In_Visible_Part -- ----------------------------------- diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index 2b3710e48ca2..4c7c9e8a57a3 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -30,34 +30,6 @@ with Types; use Types; package Exp_Disp is - ------------------------------- - -- SCIL Node Type Definition -- - ------------------------------- - - -- SCIL nodes are a special kind of nodes added to the tree when the - -- CodePeer mode is active. They are stored in the tree as special - -- N_Null_Statement nodes that have extra attributes. The information - -- available through these extra attributes relies on the kind of SCIL - -- node. The SCIL node kind is stored in the Scil_Nkind attribute of - -- the N_Null_Statement node, and indicates the type of the SCIL node. - - type SCIL_Node_Kind is - (Unused, - -- What is this for ??? - - IP_Tag_Init, - -- SCIL node for tag component initialization - - Dispatching_Call, - -- SCIL node for dispatching call. Used by the CodePeer backend to - -- locate nodes associated with dispatching calls. - - Dispatch_Table_Object_Init, - -- SCIL node for object declaration containing a dispatch table - - Dispatch_Table_Tag_Init); - -- SCIL node for tag initialization - ------------------------------------- -- Predefined primitive operations -- ------------------------------------- @@ -198,6 +170,10 @@ package Exp_Disp is -- Exp_Disp.Default_Prim_Op_Position - indirect use -- Exp_Disp.Set_All_DT_Position - direct use + procedure Adjust_SCIL_Node (Old_Node : Node_Id; New_Node : Node_Id); + -- Searches for a SCIL dispatching node associated with Old_Node. If found + -- then update its SCIL_Related_Node field to reference New_Node. + procedure Apply_Tag_Checks (Call_Node : Node_Id); -- Generate checks required on dispatching calls @@ -243,8 +219,9 @@ package Exp_Disp is -- Otherwise they are set to the defining identifier and the subprogram -- body of the generated thunk. - function Get_SCIL_Node_Kind (Node : Node_Id) return SCIL_Node_Kind; - -- Returns the kind of an SCIL node + function Find_SCIL_Node (Node : Node_Id) return Node_Id; + -- Searches for a SCIL dispatching node associated with Node. If not found + -- then return Empty. function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean; -- Ada 2005 (AI-251): Determines if E is a predefined primitive operation @@ -340,15 +317,6 @@ package Exp_Disp is -- tagged types this routine imports the forward declaration of the tag -- entity, that will be declared and exported by Make_DT. - function New_SCIL_Node - (SN_Kind : SCIL_Node_Kind; - Related_Node : Node_Id; - Entity : Entity_Id := Empty; - Target_Prim : Entity_Id := Empty) return Node_Id; - -- Creates a new Scil node. Related_Node is the AST node associated with - -- this Scil node. Entity is the tagged type associated with the Scil node. - -- For Dispatching_Call nodes, Target_Prim is the dispatching primitive. - function Register_Primitive (Loc : Source_Ptr; Prim : Entity_Id) return List_Id; diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index d139a2bc3212..d77b1db7a3b7 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -32,6 +32,7 @@ with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; +with Exp_Disp; use Exp_Disp; with Inline; use Inline; with Itypes; use Itypes; with Lib; use Lib; @@ -2755,6 +2756,10 @@ package body Exp_Util is N_Real_Range_Specification | N_Record_Definition | N_Reference | + N_SCIL_Dispatch_Table_Object_Init | + N_SCIL_Dispatch_Table_Tag_Init | + N_SCIL_Dispatching_Call | + N_SCIL_Tag_Init | N_Selected_Component | N_Signed_Integer_Type_Definition | N_Single_Protected_Declaration | @@ -4634,6 +4639,15 @@ package body Exp_Util is Constant_Present => True, Expression => Relocate_Node (Exp)); + -- Check if the previous node relocation requires readjustment of + -- some SCIL Dispatching node. + + if Generate_SCIL + and then Nkind (Exp) = N_Function_Call + then + Adjust_SCIL_Node (Exp, Expression (E)); + end if; + Set_Assignment_OK (E); Insert_Action (Exp, E); @@ -4794,6 +4808,16 @@ package body Exp_Util is Defining_Identifier => Obj, Object_Definition => New_Occurrence_Of (Exp_Type, Loc), Expression => Relocate_Node (Exp)); + + -- Check if the previous node relocation requires readjustment + -- of some SCIL Dispatching node. + + if Generate_SCIL + and then Nkind (Exp) = N_Function_Call + then + Adjust_SCIL_Node (Exp, Expression (Decl)); + end if; + Insert_Action (Exp, Decl); Set_Etype (Obj, Exp_Type); Rewrite (Exp, New_Occurrence_Of (Obj, Loc)); @@ -4853,6 +4877,15 @@ package body Exp_Util is Defining_Identifier => Def_Id, Object_Definition => New_Reference_To (Ref_Type, Loc), Expression => New_Exp)); + + -- Check if the previous node relocation requires readjustment + -- of some SCIL Dispatching node. + + if Generate_SCIL + and then Nkind (Exp) = N_Function_Call + then + Adjust_SCIL_Node (Exp, Prefix (New_Exp)); + end if; end if; -- Preserve the Assignment_OK flag in all copies, since at least diff --git a/gcc/ada/frontend.adb b/gcc/ada/frontend.adb index 7109383555f2..00eb5ca443ff 100644 --- a/gcc/ada/frontend.adb +++ b/gcc/ada/frontend.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2008, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-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- -- @@ -63,6 +63,40 @@ with Tbuild; use Tbuild; with Types; use Types; procedure Frontend is + + -- Comment: I think SCIL processing is gettings scattered too much, this + -- is a good case, why should the top level frontend driver be doing stuff + -- at this level, seems wrong to me. I think we should introduce a new + -- unit Sem_SCIL, and move a lot of this SCIL stuff there. ??? + + function Check_SCIL_Node (N : Node_Id) return Traverse_Result; + -- Process a single node during the tree traversal, verifying that field + -- SCIL_Related_Node of SCIL dispatching call nodes reference subprogram + -- calls. + + procedure Check_SCIL_Nodes is new Traverse_Proc (Check_SCIL_Node); + -- The traversal procedure itself + + --------------------- + -- Check_SCIL_Node -- + --------------------- + + function Check_SCIL_Node (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_SCIL_Dispatching_Call then + if not Nkind_In (SCIL_Related_Node (N), N_Function_Call, + N_Procedure_Call_Statement) + then + pragma Assert (False); + raise Program_Error; + end if; + + return Skip; + else + return OK; + end if; + end Check_SCIL_Node; + Config_Pragmas : List_Id; -- Gather configuration pragmas @@ -366,6 +400,13 @@ begin Exp_Dbug.Qualify_All_Entity_Names; end if; + -- SCIL backend requirement. Check that SCIL nodes associated with + -- dispatching calls reference subprogram calls. + + if Generate_SCIL then + Check_SCIL_Nodes (Cunit (Main_Unit)); + end if; + -- Dump the source now. Note that we do this as soon as the analysis -- of the tree is complete, because it is not just a dump in the case -- of -gnatD, where it rewrites all source locations in the tree. diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 12599675d83e..0dcc5937e1a7 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -3494,7 +3494,11 @@ gnat_to_gnu (Node_Id gnat_node) If we are in the elaboration procedure, check if we are violating a No_Elaboration_Code restriction by having a statement there. */ if ((IN (Nkind (gnat_node), N_Statement_Other_Than_Procedure_Call) - && Nkind (gnat_node) != N_Null_Statement) + && Nkind (gnat_node) != N_Null_Statement + && Nkind (gnat_node) != N_SCIL_Dispatch_Table_Object_Init + && Nkind (gnat_node) != N_SCIL_Dispatch_Table_Tag_Init + && Nkind (gnat_node) != N_SCIL_Dispatching_Call + && Nkind (gnat_node) != N_SCIL_Tag_Init) || Nkind (gnat_node) == N_Procedure_Call_Statement || Nkind (gnat_node) == N_Label || Nkind (gnat_node) == N_Implicit_Label_Declaration @@ -5290,6 +5294,15 @@ gnat_to_gnu (Node_Id gnat_node) gnu_result = alloc_stmt_list (); break; + /* SCIL nodes require no processing by this backend */ + + case N_SCIL_Dispatch_Table_Object_Init: + case N_SCIL_Dispatch_Table_Tag_Init: + case N_SCIL_Dispatching_Call: + case N_SCIL_Tag_Init: + gnu_result = alloc_stmt_list (); + break; + case N_Raise_Statement: case N_Function_Specification: case N_Procedure_Specification: diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 3798ac74a7aa..ca4fe86c8f6a 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -112,9 +112,12 @@ procedure Gnat1drv is procedure Adjust_Global_Switches is begin - -- Debug flag -gnatd.I is a synonym of Generate_SCIL + -- Debug flag -gnatd.I is a synonym for Generate_SCIL and requires code + -- generation. - if Debug_Flag_Dot_II then + if Debug_Flag_Dot_II + and then Operating_Mode = Generate_Code + then Generate_SCIL := True; end if; diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index d40b55c06654..8e2acdda7cae 100644 --- a/gcc/ada/sem.adb +++ b/gcc/ada/sem.adb @@ -603,6 +603,18 @@ package body Sem is when N_Push_Pop_xxx_Label => null; + -- SCIL nodes don't need analysis because they are decorated when + -- they are built. They are added to the tree by Insert_Actions and + -- the call to analyze them is generated when the full list is + -- analyzed. + + when + N_SCIL_Dispatch_Table_Object_Init | + N_SCIL_Dispatch_Table_Tag_Init | + N_SCIL_Dispatching_Call | + N_SCIL_Tag_Init => + null; + -- For the remaining node types, we generate compiler abort, because -- these nodes are always analyzed within the Sem_Chn routines and -- there should never be a case of making a call to the main Analyze diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index c1b3a3318926..20e254e8be6c 100755 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -33,6 +33,7 @@ with Atree; use Atree; with Einfo; use Einfo; with Namet; use Namet; +with Nlists; use Nlists; with Sinfo; use Sinfo; with Snames; use Snames; with Stand; use Stand; @@ -235,6 +236,22 @@ package body Sem_Aux is return Ent; end First_Discriminant; + ------------------------- + -- 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; + ------------------------------- -- First_Stored_Discriminant -- ------------------------------- @@ -736,6 +753,22 @@ package body Sem_Aux is end if; end Nearest_Dynamic_Scope; + ------------------------ + -- 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; + ------------------------ -- Next_Tag_Component -- ------------------------ diff --git a/gcc/ada/sem_aux.ads b/gcc/ada/sem_aux.ads index 464a764a3e3b..6756968fc9c8 100755 --- a/gcc/ada/sem_aux.ads +++ b/gcc/ada/sem_aux.ads @@ -138,6 +138,9 @@ package Sem_Aux is -- discriminants from Gigi's standpoint, i.e. those that will be stored in -- actual objects of the type. + function First_Non_SCIL_Node (L : List_Id) return Node_Id; + -- Returns the first non-SCIL node of list L + function First_Subtype (Typ : Entity_Id) return Entity_Id; -- Applies to all types and subtypes. For types, yields the first subtype -- of the type. For subtypes, yields the first subtype of the base type of @@ -185,6 +188,10 @@ package Sem_Aux is -- a dynamic scope, then it is returned. Otherwise the result is the same -- as that returned by Enclosing_Dynamic_Scope. + function Next_Non_SCIL_Node (N : Node_Id) return Node_Id; + -- N must be a member of a list. Returns the next non SCIL node in the list + -- containing N, or Empty if this is the last non SCIL node in the list. + function Next_Tag_Component (Tag : Entity_Id) return Entity_Id; -- Tag must be an entity representing a _Tag field of a tagged record. -- The result returned is the next _Tag field in this record, or Empty diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 826380e4c279..7ec6ab38083c 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -28,6 +28,7 @@ with Debug; use Debug; with Einfo; use Einfo; with Elists; use Elists; with Errout; use Errout; +with Exp_Disp; use Exp_Disp; with Exp_Util; use Exp_Util; with Fname; use Fname; with Itypes; use Itypes; @@ -3875,6 +3876,15 @@ package body Sem_Ch4 is T : Entity_Id; begin + -- Check if the expression is a function call for which we need to + -- adjust a SCIL dispatching node. + + if Generate_SCIL + and then Nkind (Expr) = N_Function_Call + then + Adjust_SCIL_Node (N, Expr); + end if; + -- If Conversion_OK is set, then the Etype is already set, and the -- only processing required is to analyze the expression. This is -- used to construct certain "illegal" conversions which are not diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb index fe7ffbc49c3a..3e0919f7dd78 100644 --- a/gcc/ada/sem_ch5.adb +++ b/gcc/ada/sem_ch5.adb @@ -28,6 +28,7 @@ with Checks; use Checks; with Einfo; use Einfo; with Errout; use Errout; with Expander; use Expander; +with Exp_Disp; use Exp_Disp; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Lib; use Lib; @@ -1570,6 +1571,15 @@ package body Sem_Ch5 is Name => New_Occurrence_Of (Id, Loc), Expression => Relocate_Node (Original_Bound)); + -- If the relocated node is a function call then check if some + -- SCIL node references it and needs readjustment. + + if Generate_SCIL + and then Nkind (Original_Bound) = N_Function_Call + then + Adjust_SCIL_Node (Original_Bound, Expression (Assign)); + end if; + Insert_Before (Parent (N), Assign); Analyze (Assign); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index caf4cc7a0ee4..6497be32cb09 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -5229,6 +5229,16 @@ package body Sem_Util is begin Save_Interps (N, New_Prefix); + + -- Check if the node relocation requires readjustment of some SCIL + -- dispatching node. + + if Generate_SCIL + and then Nkind (N) = N_Function_Call + then + Adjust_SCIL_Node (N, New_Prefix); + end if; + Rewrite (N, Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix)); Set_Etype (N, Designated_Type (Etype (New_Prefix))); diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 3ecaf513ffe4..816adcf5afcf 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1703,14 +1703,6 @@ package body Sinfo is return Flag7 (N); end Is_Protected_Subprogram_Body; - function Is_SCIL_Node - (N : Node_Id) return Boolean is - begin - pragma Assert (False - or else NT (N).Nkind = N_Null_Statement); - return Flag4 (N); - end Is_SCIL_Node; - function Is_Static_Coextension (N : Node_Id) return Boolean is begin @@ -2541,27 +2533,33 @@ package body Sinfo is return Flag18 (N); end Rounded_Result; - function SCIL_Entity + function SCIL_Controlling_Tag (N : Node_Id) return Node_Id is begin pragma Assert (False - or else NT (N).Nkind = N_Null_Statement); - return Node4 (N); - end SCIL_Entity; + or else NT (N).Nkind = N_SCIL_Dispatching_Call); + return Node5 (N); + end SCIL_Controlling_Tag; - function SCIL_Nkind - (N : Node_Id) return Uint is + function SCIL_Entity + (N : Node_Id) return Node_Id is begin pragma Assert (False - or else NT (N).Nkind = N_Null_Statement); - return Uint3 (N); - end SCIL_Nkind; + or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init + or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init + or else NT (N).Nkind = N_SCIL_Dispatching_Call + or else NT (N).Nkind = N_SCIL_Tag_Init); + return Node4 (N); + end SCIL_Entity; function SCIL_Related_Node (N : Node_Id) return Node_Id is begin pragma Assert (False - or else NT (N).Nkind = N_Null_Statement); + or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init + or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init + or else NT (N).Nkind = N_SCIL_Dispatching_Call + or else NT (N).Nkind = N_SCIL_Tag_Init); return Node1 (N); end SCIL_Related_Node; @@ -2569,7 +2567,7 @@ package body Sinfo is (N : Node_Id) return Node_Id is begin pragma Assert (False - or else NT (N).Nkind = N_Null_Statement); + or else NT (N).Nkind = N_SCIL_Dispatching_Call); return Node2 (N); end SCIL_Target_Prim; @@ -4557,14 +4555,6 @@ package body Sinfo is Set_Flag7 (N, Val); end Set_Is_Protected_Subprogram_Body; - procedure Set_Is_SCIL_Node - (N : Node_Id; Val : Boolean := True) is - begin - pragma Assert (False - or else NT (N).Nkind = N_Null_Statement); - Set_Flag4 (N, Val); - end Set_Is_SCIL_Node; - procedure Set_Is_Static_Coextension (N : Node_Id; Val : Boolean := True) is begin @@ -5395,36 +5385,42 @@ package body Sinfo is Set_Flag18 (N, Val); end Set_Rounded_Result; - procedure Set_SCIL_Entity + procedure Set_SCIL_Controlling_Tag (N : Node_Id; Val : Node_Id) is begin pragma Assert (False - or else NT (N).Nkind = N_Null_Statement); - Set_Node4 (N, Val); -- semantic field, no parent set - end Set_SCIL_Entity; + or else NT (N).Nkind = N_SCIL_Dispatching_Call); + Set_Node5 (N, Val); -- semantic field, no parent set + end Set_SCIL_Controlling_Tag; - procedure Set_SCIL_Nkind - (N : Node_Id; Val : Uint) is + procedure Set_SCIL_Entity + (N : Node_Id; Val : Node_Id) is begin pragma Assert (False - or else NT (N).Nkind = N_Null_Statement); - Set_Uint3 (N, Val); - end Set_SCIL_Nkind; + or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init + or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init + or else NT (N).Nkind = N_SCIL_Dispatching_Call + or else NT (N).Nkind = N_SCIL_Tag_Init); + Set_Node4 (N, Val); -- semantic field, no parent set + end Set_SCIL_Entity; procedure Set_SCIL_Related_Node (N : Node_Id; Val : Node_Id) is begin pragma Assert (False - or else NT (N).Nkind = N_Null_Statement); - Set_Node1 (N, Val); + or else NT (N).Nkind = N_SCIL_Dispatch_Table_Object_Init + or else NT (N).Nkind = N_SCIL_Dispatch_Table_Tag_Init + or else NT (N).Nkind = N_SCIL_Dispatching_Call + or else NT (N).Nkind = N_SCIL_Tag_Init); + Set_Node1 (N, Val); -- semantic field, no parent set end Set_SCIL_Related_Node; procedure Set_SCIL_Target_Prim (N : Node_Id; Val : Node_Id) is begin pragma Assert (False - or else NT (N).Nkind = N_Null_Statement); - Set_Node2 (N, Val); + or else NT (N).Nkind = N_SCIL_Dispatching_Call); + Set_Node2 (N, Val); -- semantic field, no parent set end Set_SCIL_Target_Prim; procedure Set_Scope diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index bf0841fb5b5e..2b51273a9393 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1251,15 +1251,6 @@ package Sinfo is -- handler to make sure that the associated protected object is unlocked -- when the subprogram completes. - -- Is_SCIL_Node (Flag4-Sem) - -- Present in N_Null_Statement nodes. Set to indicate that it is a SCIL - -- node. SCIL nodes are special nodes that help the CodePeer backend - -- locating nodes that require special processing. In order to minimize - -- the impact on the compiler and ASIS, and also to maximize flexibility - -- when adding SCIL nodes to the tree, instead of adding new kind of - -- nodes, SCIL nodes are added to the tree as N_Null_Statement nodes on - -- which this attribute is set. - -- Is_Static_Coextension (Flag14-Sem) -- Present in N_Allocator nodes. Set if the allocator is a coextension -- of an object allocated on the stack rather than the heap. @@ -1599,21 +1590,20 @@ package Sinfo is -- and multiplication operations. -- SCIL_Entity (Node4-Sem) - -- Present in N_Null_Statement nodes that are SCIL nodes. Used to - -- reference the tagged type associated with the SCIL node. - - -- SCIL_Nkind (Uint3-Sem) - -- Present in N_Null_Statement nodes that are SCIL nodes. Used to - -- indicate the kind of SCIL node (see SCIL node kinds in exp_disp.ads). + -- Present in SCIL nodes. Used to reference the tagged type associated + -- with the SCIL node. -- SCIL_Related_Node (Node1-Sem) - -- Present in N_Null_Statement nodes that are SCIL nodes. Used to - -- reference a tree node that requires special processing in the - -- CodePeer backend. + -- Present in SCIL nodes. Used to reference a tree node that requires + -- special processing in the CodePeer backend. + + -- SCIL_Controlling_Tag (Node5-Sem) + -- Present in N_SCIL_Dispatching_Call nodes. Used to reference the + -- controlling tag of a dispatching call. -- SCIL_Target_Prim (Node2-Sem) - -- Present in N_Null_Statement nodes. Used to reference the tagged type - -- primitive associated with the SCIL node. + -- Present in N_SCIL_Dispatching_Call nodes. Used to reference the tagged + -- type primitive associated with the SCIL node. -- Scope (Node3-Sem) -- Present in defining identifiers, defining character literals and @@ -3862,11 +3852,6 @@ package Sinfo is -- N_Null_Statement -- Sloc points to NULL - -- Is_SCIL_Node (Flag4-Sem) - -- SCIL_Nkind (Uint3-Sem) - -- SCIL_Related_Node (Node1-Sem) - -- SCIL_Entity (Node4-Sem) - -- SCIL_Target_Prim (Node2-Sem) ---------------- -- 5.1 Label -- @@ -6861,6 +6846,42 @@ package Sinfo is -- Note: in the case where a debug source file is generated, the Sloc -- for this node points to the quote in the Sprint file output. + ----------------- + -- SCIL Nodes -- + ----------------- + + -- SCIL nodes are special nodes added to the tree when the CodePeer mode + -- is active. They help CodePeer backend to locate nodes that require + -- special processing. + + -- Where is the detailed description of what these nodes are for??? The + -- above is not sufficient. The description should be here, or perhaps + -- it could be in a new Sem_SCIL unit, with a pointer from here. But + -- right now I am afraid this documentation is missing and the purpose + -- of these nodes remains secret??? + + -- N_SCIL_Dispatch_Table_Object_Init + -- Sloc references a declaration node containing a dispatch table + -- SCIL_Related_Node (Node1-Sem) + -- SCIL_Entity (Node4-Sem) + + -- N_SCIL_Dispatch_Table_Tag_Init + -- Sloc references a node for a tag initialization + -- SCIL_Related_Node (Node1-Sem) + -- SCIL_Entity (Node4-Sem) + + -- N_SCIL_Dispatching_Call + -- Sloc references the node of a dispatching call + -- SCIL_Related_Node (Node1-Sem) + -- SCIL_Target_Prim (Node2-Sem) + -- SCIL_Entity (Node4-Sem) + -- SCIL_Controlling_Tag (Node5-Sem) + + -- N_SCIL_Tag_Init + -- Sloc references the node of a tag component initialization + -- SCIL_Related_Node (Node1-Sem) + -- SCIL_Entity (Node4-Sem) + --------------------- -- Subprogram_Info -- --------------------- @@ -7298,6 +7319,13 @@ package Sinfo is N_Pop_Program_Error_Label, N_Pop_Storage_Error_Label, + -- SCIL nodes + + N_SCIL_Dispatch_Table_Object_Init, + N_SCIL_Dispatch_Table_Tag_Init, + N_SCIL_Dispatching_Call, + N_SCIL_Tag_Init, + -- Other nodes (not part of any subtype class) N_Abortable_Part, @@ -7430,12 +7458,6 @@ package Sinfo is N_Attribute_Reference; -- Nodes that have Entity fields -- Warning: DOES NOT INCLUDE N_Freeze_Entity! - -- - -- Warning: DOES NOT INCLUDE N_Null_Assignment because it not always - -- available. The Entity attribute is only available in SCIL nodes - -- (that is, N_Null_Assignment nodes that have Is_Scil_Node set to true). - -- Processing such nodes never requires testing if the node is in - -- N_Has_Entity node kind. subtype N_Has_Etype is Node_Kind range N_Error .. @@ -7511,8 +7533,12 @@ package Sinfo is N_Attribute_Definition_Clause; subtype N_Short_Circuit is Node_Kind range - N_And_Then .. - N_Or_Else; + N_And_Then .. + N_Or_Else; + + subtype N_SCIL_Node is Node_Kind range + N_SCIL_Dispatch_Table_Object_Init .. + N_SCIL_Tag_Init; subtype N_Statement_Other_Than_Procedure_Call is Node_Kind range N_Abort_Statement .. @@ -8088,9 +8114,6 @@ package Sinfo is function Is_Protected_Subprogram_Body (N : Node_Id) return Boolean; -- Flag7 - function Is_SCIL_Node - (N : Node_Id) return Boolean; -- Flag4 - function Is_Static_Coextension (N : Node_Id) return Boolean; -- Flag14 @@ -8346,12 +8369,12 @@ package Sinfo is function Rounded_Result (N : Node_Id) return Boolean; -- Flag18 + function SCIL_Controlling_Tag + (N : Node_Id) return Node_Id; -- Node5 + function SCIL_Entity (N : Node_Id) return Node_Id; -- Node4 - function SCIL_Nkind - (N : Node_Id) return Uint; -- Uint3 - function SCIL_Related_Node (N : Node_Id) return Node_Id; -- Node1 @@ -9000,9 +9023,6 @@ package Sinfo is procedure Set_Is_Protected_Subprogram_Body (N : Node_Id; Val : Boolean := True); -- Flag7 - procedure Set_Is_SCIL_Node - (N : Node_Id; Val : Boolean := True); -- Flag4 - procedure Set_Is_Static_Coextension (N : Node_Id; Val : Boolean := True); -- Flag14 @@ -9258,12 +9278,12 @@ package Sinfo is procedure Set_Rounded_Result (N : Node_Id; Val : Boolean := True); -- Flag18 + procedure Set_SCIL_Controlling_Tag + (N : Node_Id; Val : Node_Id); -- Node5 + procedure Set_SCIL_Entity (N : Node_Id; Val : Node_Id); -- Node4 - procedure Set_SCIL_Nkind - (N : Node_Id; Val : Uint); -- Uint3 - procedure Set_SCIL_Related_Node (N : Node_Id; Val : Node_Id); -- Node1 @@ -10998,6 +11018,36 @@ package Sinfo is -- End of inserted output from makeisf program + -- Entries for SCIL nodes + + N_SCIL_Dispatch_Table_Object_Init => + (1 => False, -- SCIL_Related_Node (Node1-Sem) + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- SCIL_Entity (Node4-Sem) + 5 => False), -- unused + + N_SCIL_Dispatch_Table_Tag_Init => + (1 => False, -- SCIL_Related_Node (Node1-Sem) + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- SCIL_Entity (Node4-Sem) + 5 => False), -- unused + + N_SCIL_Dispatching_Call => + (1 => False, -- SCIL_Related_Node (Node1-Sem) + 2 => False, -- SCIL_Target_Prim (Node2-Sem) + 3 => False, -- unused + 4 => False, -- SCIL_Entity (Node4-Sem) + 5 => False), -- SCIL_Controlling_Tag (Node5-Sem) + + N_SCIL_Tag_Init => + (1 => False, -- SCIL_Related_Node (Node1-Sem) + 2 => False, -- unused + 3 => False, -- unused + 4 => False, -- SCIL_Entity (Node4-Sem) + 5 => False), -- unused + -- Entries for Empty, Error and Unused. Even thought these have a Chars -- field for debugging purposes, they are not really syntactic fields, so -- we mark all fields as unused. @@ -11210,7 +11260,6 @@ package Sinfo is pragma Inline (Is_Overloaded); pragma Inline (Is_Power_Of_2_For_Shift); pragma Inline (Is_Protected_Subprogram_Body); - pragma Inline (Is_SCIL_Node); pragma Inline (Is_Static_Coextension); pragma Inline (Is_Static_Expression); pragma Inline (Is_Subprogram_Descriptor); @@ -11296,8 +11345,8 @@ package Sinfo is pragma Inline (Reverse_Present); pragma Inline (Right_Opnd); pragma Inline (Rounded_Result); + pragma Inline (SCIL_Controlling_Tag); pragma Inline (SCIL_Entity); - pragma Inline (SCIL_Nkind); pragma Inline (SCIL_Related_Node); pragma Inline (SCIL_Target_Prim); pragma Inline (Scope); @@ -11510,7 +11559,6 @@ package Sinfo is pragma Inline (Set_Is_Overloaded); pragma Inline (Set_Is_Power_Of_2_For_Shift); pragma Inline (Set_Is_Protected_Subprogram_Body); - pragma Inline (Set_Is_SCIL_Node); pragma Inline (Set_Has_Self_Reference); pragma Inline (Set_Is_Static_Coextension); pragma Inline (Set_Is_Static_Expression); @@ -11596,8 +11644,8 @@ package Sinfo is pragma Inline (Set_Reverse_Present); pragma Inline (Set_Right_Opnd); pragma Inline (Set_Rounded_Result); + pragma Inline (Set_SCIL_Controlling_Tag); pragma Inline (Set_SCIL_Entity); - pragma Inline (Set_SCIL_Nkind); pragma Inline (Set_SCIL_Related_Node); pragma Inline (Set_SCIL_Target_Prim); pragma Inline (Set_Scope); diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb index ec042b9ed792..e73d204d7586 100644 --- a/gcc/ada/sprint.adb +++ b/gcc/ada/sprint.adb @@ -2637,6 +2637,23 @@ package body Sprint is Write_Char (';'); + -- Don't we want to print more detail??? + + -- Doc of this extended syntax belongs in sinfo.ads and/or + -- sprint.ads ??? + + when N_SCIL_Dispatch_Table_Object_Init => + Write_Indent_Str ("[N_SCIL_Dispatch_Table_Object_Init]"); + + when N_SCIL_Dispatch_Table_Tag_Init => + Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]"); + + when N_SCIL_Dispatching_Call => + Write_Indent_Str ("[N_SCIL_Dispatching_Node]"); + + when N_SCIL_Tag_Init => + Write_Indent_Str ("[N_SCIL_Dispatch_Table_Tag_Init]"); + when N_Simple_Return_Statement => if Present (Expression (Node)) then Write_Indent_Str_Sloc ("return ");