+2009-07-28 Javier Miranda <miranda@adacore.com>
+
+ * 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 <dewar@adacore.com>
* prj-nmsc.adb, g-expect.adb, prj.ads: Minor reformatting
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);
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;
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
-- 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
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
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);
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))
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
-- 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 --
----------------------
end if;
end New_Value;
+ -- Local variables
+
+ SCIL_Node : Node_Id;
+
-- Start of processing for Expand_Dispatching_Call
begin
-- 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
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)
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 --
-- 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,
-- 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:
-- 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,
-- 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,
-- 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,
-- 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,
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;
-- 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,
-- 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;
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 --
-----------------------------------
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 --
-------------------------------------
-- 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
-- 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
-- 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;
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;
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 |
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);
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));
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
-- --
-- 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- --
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
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.
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
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:
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;
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
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;
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 --
-------------------------------
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 --
------------------------
-- 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
-- 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
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;
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
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;
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);
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)));
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
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;
(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;
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
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
-- 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.
-- 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
-- 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 --
-- 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 --
---------------------
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,
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 ..
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 ..
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
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
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
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
-- 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.
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);
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);
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);
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);
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 ");
projects / thirdparty / gcc.git / commitdiff
