FreeChainXenon/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

frontend.adb (Frontend): Code cleanup.

Browse source 
2009-07-29  Javier Miranda  <miranda@adacore.com>

	* frontend.adb (Frontend): Code cleanup.
	* exp_atag.ads, exp_atag.adb (Build_Get_Predefined_Prim_Op_Address):
	Rewriten as a procedure because it a new out-mode parameters to
	keep up-to-date the controlling tag node in the caller.
	(Build_Get_Prim_Op_Address): Rewriten as a procedure because it has a
	new out-mode parameter to keep up-to-date the controlling tag node in
	the caller.
	* exp_ch7.adb, sem_ch5.adb, exp_util.adb, sem_util.adb, exp_ch4.adb,
	exp_ch6.adb, sem_ch4.adb, exp_ch3.adb: Add new dependency on new
	package Sem_SCIL.
	* sem_aux.ads, sem_aux.adb (First_Non_SCIL_Node): Removed. Routine
	available in new package Sem_SCIL.
	(Next_Non_SCIL_Node): Ditto.
	* exp_disp.adb (Adjust_SCIL_Node): Removed. Routine available in new
	package Sem_SCIL.
	(Expand_Dispatching_Call): Update call to modified Exp_Atags routines
	plus complete decoration of SCIL dispatching node.
	(Find_SCIL_Node): Removed. Routine available in new package Sem_SCIL.
	* exp_disp.ads (Adjust_SCIL_Node): Removed. Routine available in new
	package Sem_SCIL.
	(Find_SCIL_Node): Removed. Routine available in new package Sem_SCIL.
	* exp_ch3.adb (Build_Init_Procedure): Fix comment.
	* sem_scil.ads, sem_scil.adb: New files.
	* gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Addition of sem_scil.o.
	Update dependencies.

From-SVN: r150199
This commit is contained in:
Javier Miranda 2009-07-29 08:43:58 +00:00 • committed by Arnaud Charlet
parent bc4eac6d04
commit d06b3b1df8
19 changed files with 1375 additions and 1079 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
gcc/ada/ChangeLog
View file

@ -1,3 +1,31 @@
2009-07-29 Javier Miranda <miranda@adacore.com>
* frontend.adb (Frontend): Code cleanup.
* exp_atag.ads, exp_atag.adb (Build_Get_Predefined_Prim_Op_Address):
Rewriten as a procedure because it a new out-mode parameters to
keep up-to-date the controlling tag node in the caller.
(Build_Get_Prim_Op_Address): Rewriten as a procedure because it has a
new out-mode parameter to keep up-to-date the controlling tag node in
the caller.
* exp_ch7.adb, sem_ch5.adb, exp_util.adb, sem_util.adb, exp_ch4.adb,
exp_ch6.adb, sem_ch4.adb, exp_ch3.adb: Add new dependency on new
package Sem_SCIL.
* sem_aux.ads, sem_aux.adb (First_Non_SCIL_Node): Removed. Routine
available in new package Sem_SCIL.
(Next_Non_SCIL_Node): Ditto.
* exp_disp.adb (Adjust_SCIL_Node): Removed. Routine available in new
package Sem_SCIL.
(Expand_Dispatching_Call): Update call to modified Exp_Atags routines
plus complete decoration of SCIL dispatching node.
(Find_SCIL_Node): Removed. Routine available in new package Sem_SCIL.
* exp_disp.ads (Adjust_SCIL_Node): Removed. Routine available in new
package Sem_SCIL.
(Find_SCIL_Node): Removed. Routine available in new package Sem_SCIL.
* exp_ch3.adb (Build_Init_Procedure): Fix comment.
* sem_scil.ads, sem_scil.adb: New files.
* gcc-interface/Make-lang.in (GNAT_ADA_OBJS): Addition of sem_scil.o.
Update dependencies.
2009-07-28 Robert Dewar <dewar@adacore.com>
* adaint.h, einfo.ads, prj.adb, sem_util.adb, makeutl.ads,

54
gcc/ada/exp_atag.adb
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2006-2008, Free Software Foundation, Inc. --
-- Copyright (C) 2006-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- --
@ -227,12 +227,22 @@ package body Exp_Atag is
-- Build_Get_Predefined_Prim_Op_Address --
------------------------------------------
function Build_Get_Predefined_Prim_Op_Address
procedure Build_Get_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position : Uint) return Node_Id
Position : Uint;
Tag_Node : in out Node_Id;
New_Node : out Node_Id)
is
Ctrl_Tag : Node_Id;
begin
Ctrl_Tag := Unchecked_Convert_To (RTE (RE_Address), Tag_Node);
-- Unchecked_Convert_To relocates the controlling tag node and therefore
-- we must update it.
Tag_Node := Expression (Ctrl_Tag);
-- Build code that retrieves the address of the dispatch table
-- containing the predefined Ada primitives:
--
@ -240,7 +250,7 @@ package body Exp_Atag is
-- To_Predef_Prims_Table_Ptr
-- (To_Addr_Ptr (To_Address (Tag) - Predef_Prims_Offset).all);
return
New_Node :=
Make_Indexed_Component (Loc,
Prefix =>
Unchecked_Convert_To (RTE (RE_Predef_Prims_Table_Ptr),
@ -257,7 +267,7 @@ package body Exp_Atag is
Make_Identifier (Loc,
Chars => Name_Op_Subtract)),
Parameter_Associations => New_List (
Unchecked_Convert_To (RTE (RE_Address), Tag_Node),
Ctrl_Tag,
New_Reference_To (RTE (RE_DT_Predef_Prims_Offset),
Loc)))))),
Expressions =>
@ -337,12 +347,15 @@ package body Exp_Atag is
-- Build_Get_Prim_Op_Address --
-------------------------------
function Build_Get_Prim_Op_Address
procedure Build_Get_Prim_Op_Address
(Loc : Source_Ptr;
Typ : Entity_Id;
Tag_Node : Node_Id;
Position : Uint) return Node_Id
Position : Uint;
Tag_Node : in out Node_Id;
New_Node : out Node_Id)
is
New_Prefix : Node_Id;
begin
pragma Assert
(Position <= DT_Entry_Count (First_Tag_Component (Typ)));
@ -351,11 +364,18 @@ package body Exp_Atag is
-- declaration required to convert the tag into a pointer to
-- the prims_ptr table (see Freeze_Record_Type).
return
New_Prefix :=
Unchecked_Convert_To
(Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node);
-- Unchecked_Convert_To relocates the controlling tag node and therefore
-- we must update it.
Tag_Node := Expression (New_Prefix);
New_Node :=
Make_Indexed_Component (Loc,
Prefix =>
Unchecked_Convert_To
(Node (Last_Elmt (Access_Disp_Table (Typ))), Tag_Node),
Prefix => New_Prefix,
Expressions => New_List (Make_Integer_Literal (Loc, Position)));
end Build_Get_Prim_Op_Address;
@ -482,11 +502,15 @@ package body Exp_Atag is
Position : Uint;
Address_Node : Node_Id) return Node_Id
is
Ctrl_Tag : Node_Id := Tag_Node;
New_Node : Node_Id;
begin
Build_Get_Prim_Op_Address (Loc, Typ, Position, Ctrl_Tag, New_Node);
return
Make_Assignment_Statement (Loc,
Name => Build_Get_Prim_Op_Address
(Loc, Typ, Tag_Node, Position),
Name => New_Node,
Expression => Address_Node);
end Build_Set_Prim_Op_Address;

19
gcc/ada/exp_atag.ads
View file

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2006-2008, Free Software Foundation, Inc. --
-- Copyright (C) 2006-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- --
@ -61,23 +61,26 @@ package Exp_Atag is
--
-- Generates: TSD (Tag).Access_Level
function Build_Get_Predefined_Prim_Op_Address
procedure Build_Get_Predefined_Prim_Op_Address
(Loc : Source_Ptr;
Tag_Node : Node_Id;
Position : Uint) return Node_Id;
Position : Uint;
Tag_Node : in out Node_Id;
New_Node : out Node_Id);
-- Given a pointer to a dispatch table (T) and a position in the DT, build
-- code that gets the address of the predefined virtual function stored in
-- it (used for dispatching calls).
-- it (used for dispatching calls). Tag_Node is relocated.
--
-- Generates: Predefined_DT (Tag).D (Position);
function Build_Get_Prim_Op_Address
procedure Build_Get_Prim_Op_Address
(Loc : Source_Ptr;
Typ : Entity_Id;
Tag_Node : Node_Id;
Position : Uint) return Node_Id;
Position : Uint;
Tag_Node : in out Node_Id;
New_Node : out Node_Id);
-- Build code that retrieves the address of the virtual function stored in
-- a given position of the dispatch table (used for dispatching calls).
-- Tag_Node is relocated.
--
-- Generates: To_Tag (Tag).D (Position);

5
gcc/ada/exp_ch3.adb
View file

@ -59,6 +59,7 @@ with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_SCIL; use Sem_SCIL;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
@ -2507,8 +2508,8 @@ package body Exp_Ch3 is
if List_Length (Body_Stmts) = 1
-- We must skip SCIL nodes because they are currently implemented
-- as special N_Null_Statement nodes.
-- 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
and then VM_Target = No_VM

1
gcc/ada/exp_ch4.adb
View file

@ -58,6 +58,7 @@ with Sem_Ch8; use Sem_Ch8;
with Sem_Ch13; use Sem_Ch13;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_SCIL; use Sem_SCIL;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;

1
gcc/ada/exp_ch6.adb
View file

@ -64,6 +64,7 @@ with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_SCIL; use Sem_SCIL;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;

1
gcc/ada/exp_ch7.adb
View file

@ -54,6 +54,7 @@ with Sem_Ch3; use Sem_Ch3;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Sem_Res; use Sem_Res;
with Sem_SCIL; use Sem_SCIL;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Snames; use Snames;

584
gcc/ada/exp_disp.adb
View file

@ -100,66 +100,6 @@ 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 --
----------------------
@ -637,6 +577,7 @@ package body Exp_Disp is
-- Local variables
New_Node : Node_Id;
SCIL_Node : Node_Id;
-- Start of processing for Expand_Dispatching_Call
@ -874,36 +815,102 @@ 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
-- Handle dispatching calls to predefined primitives.
if Is_Predefined_Dispatching_Operation (Subp)
or else Is_Predefined_Dispatching_Alias (Subp)
then
New_Call_Name :=
Unchecked_Convert_To (Subp_Ptr_Typ,
Build_Get_Predefined_Prim_Op_Address (Loc,
Tag_Node => Controlling_Tag,
Position => DT_Position (Subp)));
Build_Get_Predefined_Prim_Op_Address (Loc,
Tag_Node => Controlling_Tag,
Position => DT_Position (Subp),
New_Node => New_Node);
-- Handle dispatching calls to user-defined primitives
else
New_Call_Name :=
Unchecked_Convert_To (Subp_Ptr_Typ,
Build_Get_Prim_Op_Address (Loc,
Typ => Find_Dispatching_Type (Subp),
Tag_Node => Controlling_Tag,
Position => DT_Position (Subp)));
Build_Get_Prim_Op_Address (Loc,
Typ => Find_Dispatching_Type (Subp),
Tag_Node => Controlling_Tag,
Position => DT_Position (Subp),
New_Node => New_Node);
end if;
New_Call_Name :=
Unchecked_Convert_To (Subp_Ptr_Typ, New_Node);
-- Complete decoration of SCIL dispatching node. It must be done after
-- the new call name is built to reference the nodes that will see the
-- SCIL backend (because Build_Get_Prim_Op_Address generates an
-- unchecked type conversion which relocates the controlling tag node).
if Generate_SCIL then
-- Common case: the controlling tag is the tag of an object
-- (for example, obj.tag)
if Nkind (Controlling_Tag) = N_Selected_Component then
Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
-- Handle renaming of selected component
elsif Nkind (Controlling_Tag) = N_Identifier
and then Nkind (Parent (Entity (Controlling_Tag)))
= N_Object_Renaming_Declaration
and then Nkind (Name (Parent (Entity (Controlling_Tag))))
= N_Selected_Component
then
Set_SCIL_Controlling_Tag (SCIL_Node,
Name (Parent (Entity (Controlling_Tag))));
-- If the controlling tag is an identifier, the SCIL node references
-- the corresponding object or parameter declaration
elsif Nkind (Controlling_Tag) = N_Identifier
and then Nkind_In (Parent (Entity (Controlling_Tag)),
N_Object_Declaration,
N_Parameter_Specification)
then
Set_SCIL_Controlling_Tag (SCIL_Node,
Parent (Entity (Controlling_Tag)));
-- If the controlling tag is a dereference, the SCIL node references
-- the corresponding object or parameter declaration
elsif Nkind (Controlling_Tag) = N_Explicit_Dereference
and then Nkind (Prefix (Controlling_Tag)) = N_Identifier
and then Nkind_In (Parent (Entity (Prefix (Controlling_Tag))),
N_Object_Declaration,
N_Parameter_Specification)
then
Set_SCIL_Controlling_Tag (SCIL_Node,
Parent (Entity (Prefix (Controlling_Tag))));
-- For a direct reference of the tag of the type the SCIL node
-- references the the internal object declaration containing the tag
-- of the type.
elsif Nkind (Controlling_Tag) = N_Attribute_Reference
and then Attribute_Name (Controlling_Tag) = Name_Tag
then
Set_SCIL_Controlling_Tag (SCIL_Node,
Parent
(Node
(First_Elmt
(Access_Disp_Table (Entity (Prefix (Controlling_Tag)))))));
-- Interfaces are not supported. For now we leave the SCIL node
-- decorated with the Controlling_Tag. More work needed here???
elsif Is_Interface (Etype (Controlling_Tag)) then
Set_SCIL_Controlling_Tag (SCIL_Node, Controlling_Tag);
else
pragma Assert (False);
null;
end if;
end if;
if Nkind (Call_Node) = N_Function_Call then
New_Call :=
Make_Function_Call (Loc,
Name => New_Call_Name,
@ -1679,425 +1686,6 @@ package body Exp_Disp is
end if;
end Expand_Interface_Thunk;
--------------------
-- 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
begin
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 --
------------

8
gcc/ada/exp_disp.ads
View file

@ -170,10 +170,6 @@ 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
@ -219,10 +215,6 @@ package Exp_Disp is
-- Otherwise they are set to the defining identifier and the subprogram
-- body of the generated thunk.
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

2
gcc/ada/exp_util.adb
View file

@ -32,7 +32,6 @@ 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;
@ -44,6 +43,7 @@ with Rident; use Rident;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_SCIL; use Sem_SCIL;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Type; use Sem_Type;

39
gcc/ada/frontend.adb
View file

@ -46,12 +46,13 @@ with Prep;
with Prepcomp;
with Restrict; use Restrict;
with Rident; use Rident;
with Rtsfind;
with Rtsfind; use Rtsfind;
with Sprint;
with Scn; use Scn;
with Sem; use Sem;
with Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_SCIL;
with Sem_Elab; use Sem_Elab;
with Sem_Prag; use Sem_Prag;
with Sem_Warn; use Sem_Warn;
@ -63,40 +64,6 @@ 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
@ -404,7 +371,7 @@ begin
-- dispatching calls reference subprogram calls.
if Generate_SCIL then
pragma Debug (Check_SCIL_Nodes (Cunit (Main_Unit)));
pragma Debug (Sem_SCIL.Check_SCIL_Nodes (Cunit (Main_Unit)));
null;
end if;

960
gcc/ada/gcc-interface/Make-lang.in
View file

File diff suppressed because it is too large Load diff

33
gcc/ada/sem_aux.adb
View file

@ -33,7 +33,6 @@
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;
@ -236,22 +235,6 @@ 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 --
-------------------------------
@ -753,22 +736,6 @@ 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 --
------------------------

7
gcc/ada/sem_aux.ads
View file

@ -138,9 +138,6 @@ 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
@ -188,10 +185,6 @@ 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

2
gcc/ada/sem_ch4.adb
View file

@ -28,7 +28,6 @@ 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;
@ -48,6 +47,7 @@ with Sem_Cat; use Sem_Cat;
with Sem_Ch3; use Sem_Ch3;
with Sem_Ch6; use Sem_Ch6;
with Sem_Ch8; use Sem_Ch8;
with Sem_SCIL; use Sem_SCIL;
with Sem_Disp; use Sem_Disp;
with Sem_Dist; use Sem_Dist;
with Sem_Eval; use Sem_Eval;

2
gcc/ada/sem_ch5.adb
View file

@ -28,7 +28,6 @@ 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;
@ -47,6 +46,7 @@ with Sem_Disp; use Sem_Disp;
with Sem_Elab; use Sem_Elab;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_SCIL; use Sem_SCIL;
with Sem_Type; use Sem_Type;
with Sem_Util; use Sem_Util;
with Sem_Warn; use Sem_Warn;

649
gcc/ada/sem_scil.adb Normal file
View file

@ -0,0 +1,649 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ S C I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Einfo; use Einfo;
with Namet; use Namet;
with Nlists; use Nlists;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
package body Sem_SCIL is
----------------------
-- Adjust_SCIL_Node --
----------------------
procedure Adjust_SCIL_Node (Old_Node : Node_Id; New_Node : Node_Id) is
SCIL_Node : Node_Id;
begin
pragma Assert (Generate_SCIL);
-- Check cases in which no action is required. Currently the only SCIL
-- nodes that may require adjustment are those of dispatching calls
-- internally generated by the frontend.
if Comes_From_Source (Old_Node)
or else not
Nkind_In (New_Node, N_Function_Call, N_Procedure_Call_Statement)
then
return;
-- Conditional expression associated with equality operator. Old_Node
-- may be part of the expansion of the predefined equality operator of
-- a tagged type and hence we need to check if it has a SCIL dispatching
-- node that needs adjustment.
elsif Nkind (Old_Node) = N_Conditional_Expression
and then (Nkind (Original_Node (Old_Node)) = N_Op_Eq
or else
(Nkind (Original_Node (Old_Node)) = N_Function_Call
and then Chars (Name (Original_Node (Old_Node))) =
Name_Op_Eq))
then
null;
-- Type conversions may involve dispatching calls to functions whose
-- associated SCIL dispatching node needs adjustment.
elsif Nkind (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;
---------------------
-- Check_SCIL_Node --
---------------------
-- Is this a good name for the function, given it only deals with
-- N_SCIL_Dispatching_Call case ???
function Check_SCIL_Node (N : Node_Id) return Traverse_Result is
Ctrl_Tag : Node_Id;
Ctrl_Typ : Entity_Id;
begin
if Nkind (N) = N_SCIL_Dispatching_Call then
Ctrl_Tag := SCIL_Controlling_Tag (N);
-- SCIL_Related_Node of SCIL dispatching call nodes MUST reference
-- subprogram calls.
if not Nkind_In (SCIL_Related_Node (N), N_Function_Call,
N_Procedure_Call_Statement)
then
pragma Assert (False);
raise Program_Error;
-- In simple cases the controlling tag is the tag of the controlling
-- argument (i.e. Obj.Tag).
elsif Nkind (Ctrl_Tag) = N_Selected_Component then
Ctrl_Typ := Etype (Ctrl_Tag);
-- Interface types are unsupported
if Is_Interface (Ctrl_Typ)
or else (RTE_Available (RE_Interface_Tag)
and then Ctrl_Typ = RTE (RE_Interface_Tag))
then
null;
else
pragma Assert (Ctrl_Typ = RTE (RE_Tag));
null;
end if;
-- When the controlling tag of a dispatching call is an identifier
-- the SCIL_Controlling_Tag attribute references the corresponding
-- object or parameter declaration. Interface types are still
-- unsupported.
elsif Nkind_In (Ctrl_Tag, N_Object_Declaration,
N_Parameter_Specification)
then
Ctrl_Typ := Etype (Defining_Identifier (Ctrl_Tag));
-- Interface types are unsupported.
if Is_Interface (Ctrl_Typ)
or else (RTE_Available (RE_Interface_Tag)
and then Ctrl_Typ = RTE (RE_Interface_Tag))
or else (Is_Access_Type (Ctrl_Typ)
and then
Is_Interface
(Available_View
(Base_Type (Designated_Type (Ctrl_Typ)))))
then
null;
else
pragma Assert
(Ctrl_Typ = RTE (RE_Tag)
or else
(Is_Access_Type (Ctrl_Typ)
and then Available_View
(Base_Type (Designated_Type (Ctrl_Typ))) =
RTE (RE_Tag)));
null;
end if;
-- Interface types are unsupported
elsif Is_Interface (Etype (Ctrl_Tag)) then
null;
else
pragma Assert (False);
raise Program_Error;
end if;
return Skip;
-- Node is not N_SCIL_Dispatching_Call
else
return OK;
end if;
end Check_SCIL_Node;
--------------------
-- Find_SCIL_Node --
--------------------
function Find_SCIL_Node (Node : Node_Id) return Node_Id is
Found_Node : Node_Id;
-- This variable stores the last node found by the nested subprogram
-- Find_SCIL_Node.
function Find_SCIL_Node (L : List_Id) return Boolean;
-- Searches in list L for a SCIL node associated with a dispatching call
-- whose SCIL_Related_Node is Node. If found returns true and stores the
-- SCIL node in Found_Node; otherwise returns False and sets Found_Node
-- to Empty.
--------------------
-- Find_SCIL_Node --
--------------------
function Find_SCIL_Node (L : List_Id) return Boolean is
N : Node_Id;
begin
N := First (L);
while Present (N) loop
if Nkind (N) in N_SCIL_Node
and then SCIL_Related_Node (N) = Node
then
Found_Node := N;
return True;
end if;
Next (N);
end loop;
Found_Node := Empty;
return False;
end Find_SCIL_Node;
-- Local variables
P : Node_Id;
-- Start of processing for Find_SCIL_Node
begin
pragma Assert (Generate_SCIL);
-- Search for the SCIL node in list associated with a transient scope
if Scope_Is_Transient then
declare
SE : Scope_Stack_Entry
renames Scope_Stack.Table (Scope_Stack.Last);
begin
if SE.Is_Transient
and then Present (SE.Actions_To_Be_Wrapped_Before)
and then Find_SCIL_Node (SE.Actions_To_Be_Wrapped_Before)
then
return Found_Node;
end if;
end;
end if;
-- Otherwise climb up the tree searching for the SCIL node analyzing
-- all the lists in which Insert_Actions may have inserted it
P := Node;
while Present (P) loop
case Nkind (P) is
-- Actions associated with AND THEN or OR ELSE
when N_Short_Circuit =>
if Present (Actions (P))
and then Find_SCIL_Node (Actions (P))
then
return Found_Node;
end if;
-- Actions of conditional expressions
when N_Conditional_Expression =>
if (Present (Then_Actions (P))
and then Find_SCIL_Node (Actions (P)))
or else
(Present (Else_Actions (P))
and then Find_SCIL_Node (Else_Actions (P)))
then
return Found_Node;
end if;
-- 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;
-------------------------
-- First_Non_SCIL_Node --
-------------------------
function First_Non_SCIL_Node (L : List_Id) return Node_Id is
N : Node_Id;
begin
N := First (L);
while Nkind (N) in N_SCIL_Node loop
Next (N);
end loop;
return N;
end First_Non_SCIL_Node;
------------------------
-- Next_Non_SCIL_Node --
------------------------
function Next_Non_SCIL_Node (N : Node_Id) return Node_Id is
Aux_N : Node_Id;
begin
Aux_N := Next (N);
while Nkind (Aux_N) in N_SCIL_Node loop
Next (Aux_N);
end loop;
return Aux_N;
end Next_Non_SCIL_Node;
end Sem_SCIL;

58
gcc/ada/sem_scil.ads Normal file
View file

@ -0,0 +1,58 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S E M _ S C I L --
-- --
-- B o d y --
-- --
-- Copyright (C) 2009, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package contains routines involved in the frontend addition and
-- verification of SCIL nodes.
with Atree; use Atree;
with Types; use Types;
package Sem_SCIL is
-- Here would be a good place to document what SCIL is all about ???
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.
function Check_SCIL_Node (N : Node_Id) return Traverse_Result;
-- Process a single node during the tree traversal. Done to verify that
-- SCIL nodes decoration fulfill the requirements of the SCIL backend.
procedure Check_SCIL_Nodes is new Traverse_Proc (Check_SCIL_Node);
-- The traversal procedure itself
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 First_Non_SCIL_Node (L : List_Id) return Node_Id;
-- Returns the first non-SCIL node of list L
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.
end Sem_SCIL;

1
gcc/ada/sem_util.adb
View file

@ -50,6 +50,7 @@ with Sem_Ch8; use Sem_Ch8;
with Sem_Disp; use Sem_Disp;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_SCIL; use Sem_SCIL;
with Sem_Type; use Sem_Type;
with Sinfo; use Sinfo;
with Sinput; use Sinput;