OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2010-06-23  Robert Dewar  <dewar@adacore.com>

	* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Properly handle
	checking returns in generic case.
	(Check_Missing_Return): New procedure.

2010-06-23  Robert Dewar  <dewar@adacore.com>

	* bindgen.adb, switch-b.adb: Minor reformatting.

2010-06-23  Javier Miranda  <miranda@adacore.com>

	* frontend.adb (Frontend): Add call to initialize the new package
	SCIL_LL.
	* exp_ch7.adb (Wrap_Transient_Expression): Remove call to
	Adjust_SCIL_Node.
	(Wrap_Transient_Statement): Remove call to Adjust_SCIL_Node.
	* sem_ch5.adb (Analyze_Iteration_Scheme.Process_Bounds): Remove call to
	Adjust_SCIL_Node.
	* exp_util.adb (Insert_Actions): Remove code for
	N_SCIL_Dispatch_Table_Object_Init and N_SCIL_Tag_Init nodes.
	(Remove_Side_Effects): Remove calls to Adjust_SCIL_Node.
	* sinfo.adb (SCIL_Entity, SCIL_Tag_Value): Remove checks on
	N_SCIL_Tag_Init and N_SCIL_Dispatch_Table_Object_Init in the assertion.
	(SCIL_Related_Node, Set_SCIL_Related_Node): Removed.
	* sinfo.ads (SCIL_Related_Node): Field removed.
	(N_SCIL_Dispatch_Table_Object_Init): Node removed.
	(N_SCIL_Tag_Init): Node removed.
	* sem_scil.ads, sem_scil.adb (Adjust_SCIL_Node): Removed.
	(Check_SCIL_Node): New implementation.
	(Find_SCIL_Node): Removed.
	* sem.adb (Analyze): Remove management of
	N_SCIL_Dispatch_Table_Object_Init and N_SCIL_Tag_Init nodes.
	* sem_util.adb (Insert_Explicit_Dereference): Remove call to
	Adjust_SCIL_Node.
	* exp_ch4.adb (Expand_N_In): Code cleanup: remove call to
	Set_SCIL_Related_Node and avoid adding the SCIL node before the
	referenced node using Insert_Action because this is not longer required.
	(Expand_Short_Circuit_Operator): Remove call to SCIL node.
	* exp_ch6.adb (Expand_Call): Remove call to Adjust_SCIL_Node.
	* sem_ch4.adb (Analyze_Type_Conversion): Remove call to Adjust_SCIL_Node
	* exp_disp.adb (Expand_Dispatching_Call): Minor code reorganization
	because we no longer require to generate the SCIL node before the call.
	(Make_DT): Remove generation of SCI_Dispatch_Table_Object_Init node.
	Remove calls to Set_SCIL_Related_Node and avoid adding the SCIL
	nodes before the referenced node using Insert_Action because this
	is not longer required.
	* atree.adb (Allocate_Initialize_Node, Replace, Rewrite): Add call to
	update the SCIL_Node field.
	* sprint.adb (Sprint_Node_Actual): Remove code for
	N_SCIL_Dispatch_Table_Object_Init and N_SCIL_Tag_Init nodes.
	* treepr.adb (Print_Node): Print the SCIL node field (if available).
	* exp_ch3.adb (Build_Init_Procedure): Remove generation of
	SCIL_Tag_Init nodes.
	* scil_ll.ads, scil_ll.adb: New files.

From-SVN: r161244
This commit is contained in:
Arnaud Charlet 2010-06-23 08:11:20 +02:00
parent 5b9c3fc489
commit 7665e4bd2c
26 changed files with 1336 additions and 1783 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
gcc/ada/ChangeLog
View File

@ -1,3 +1,61 @@
2010-06-23 Robert Dewar <dewar@adacore.com>
* sem_ch6.adb (Analyze_Subprogram_Body_Helper): Properly handle
checking returns in generic case.
(Check_Missing_Return): New procedure.
2010-06-23 Robert Dewar <dewar@adacore.com>
* bindgen.adb, switch-b.adb: Minor reformatting.
2010-06-23 Javier Miranda <miranda@adacore.com>
* frontend.adb (Frontend): Add call to initialize the new package
SCIL_LL.
* exp_ch7.adb (Wrap_Transient_Expression): Remove call to
Adjust_SCIL_Node.
(Wrap_Transient_Statement): Remove call to Adjust_SCIL_Node.
* sem_ch5.adb (Analyze_Iteration_Scheme.Process_Bounds): Remove call to
Adjust_SCIL_Node.
* exp_util.adb (Insert_Actions): Remove code for
N_SCIL_Dispatch_Table_Object_Init and N_SCIL_Tag_Init nodes.
(Remove_Side_Effects): Remove calls to Adjust_SCIL_Node.
* sinfo.adb (SCIL_Entity, SCIL_Tag_Value): Remove checks on
N_SCIL_Tag_Init and N_SCIL_Dispatch_Table_Object_Init in the assertion.
(SCIL_Related_Node, Set_SCIL_Related_Node): Removed.
* sinfo.ads (SCIL_Related_Node): Field removed.
(N_SCIL_Dispatch_Table_Object_Init): Node removed.
(N_SCIL_Tag_Init): Node removed.
* sem_scil.ads, sem_scil.adb (Adjust_SCIL_Node): Removed.
(Check_SCIL_Node): New implementation.
(Find_SCIL_Node): Removed.
* sem.adb (Analyze): Remove management of
N_SCIL_Dispatch_Table_Object_Init and N_SCIL_Tag_Init nodes.
* sem_util.adb (Insert_Explicit_Dereference): Remove call to
Adjust_SCIL_Node.
* exp_ch4.adb (Expand_N_In): Code cleanup: remove call to
Set_SCIL_Related_Node and avoid adding the SCIL node before the
referenced node using Insert_Action because this is not longer required.
(Expand_Short_Circuit_Operator): Remove call to SCIL node.
* exp_ch6.adb (Expand_Call): Remove call to Adjust_SCIL_Node.
* sem_ch4.adb (Analyze_Type_Conversion): Remove call to Adjust_SCIL_Node
* exp_disp.adb (Expand_Dispatching_Call): Minor code reorganization
because we no longer require to generate the SCIL node before the call.
(Make_DT): Remove generation of SCI_Dispatch_Table_Object_Init node.
Remove calls to Set_SCIL_Related_Node and avoid adding the SCIL
nodes before the referenced node using Insert_Action because this
is not longer required.
* atree.adb (Allocate_Initialize_Node, Replace, Rewrite): Add call to
update the SCIL_Node field.
* sprint.adb (Sprint_Node_Actual): Remove code for
N_SCIL_Dispatch_Table_Object_Init and N_SCIL_Tag_Init nodes.
* treepr.adb (Print_Node): Print the SCIL node field (if available).
* exp_ch3.adb (Build_Init_Procedure): Remove generation of
SCIL_Tag_Init nodes.
* scil_ll.ads, scil_ll.adb: New files.
* gcc-interface/Makefile.in, gcc-interface/Make-lang.in: Update
dependencies.
2010-06-23 Robert Dewar <dewar@adacore.com>
* sem_ch6.adb: Minor reformatting.

21
gcc/ada/atree.adb
View File

@ -38,8 +38,10 @@ pragma Style_Checks (All_Checks);
with Debug; use Debug;
with Nlists; use Nlists;
with Opt; use Opt;
with Output; use Output;
with Sinput; use Sinput;
with SCIL_LL; use SCIL_LL;
with Tree_IO; use Tree_IO;
package body Atree is
@ -531,6 +533,13 @@ package body Atree is
Orig_Nodes.Set_Last (Nodes.Last);
Allocate_List_Tables (Nodes.Last);
-- Update the SCIL_Node field (if available)
if Generate_SCIL then
Set_SCIL_Node (New_Id, Get_SCIL_Node (Src));
end if;
return New_Id;
end Allocate_Initialize_Node;
@ -1570,6 +1579,12 @@ package body Atree is
-- to Rewrite if there were an intention to save the original node.
Orig_Nodes.Table (Old_Node) := Old_Node;
-- Update the SCIL_Node field (if available)
if Generate_SCIL then
Set_SCIL_Node (Old_Node, Get_SCIL_Node (New_Node));
end if;
end Replace;
-------------
@ -1628,6 +1643,12 @@ package body Atree is
end if;
Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node);
-- Update the SCIL_Node field (if available)
if Generate_SCIL then
Set_SCIL_Node (Old_Node, Get_SCIL_Node (New_Node));
end if;
end Rewrite;
-------------------------

1
gcc/ada/bindgen.adb
View File

@ -811,7 +811,6 @@ package body Bindgen is
Write_Statement_Buffer;
end if;
end if;
end if;
-- Generate call to set Initialize_Scalar values if active

18
gcc/ada/exp_ch3.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -2331,22 +2331,6 @@ package body Exp_Ch3 is
New_Reference_To
(Node (First_Elmt (Access_Disp_Table (Rec_Type))), Loc)));
-- Generate the SCIL node associated with the initialization of
-- the tag component.
if Generate_SCIL then
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
-- located at fixed positions (tags whose position depends on
-- variable size components are initialized later ---see below).

18
gcc/ada/exp_ch4.adb
View File

@ -59,13 +59,13 @@ 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;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with SCIL_LL; use SCIL_LL;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
@ -4627,8 +4627,7 @@ package body Exp_Ch4 is
if Generate_SCIL
and then Present (SCIL_Node)
then
Set_SCIL_Related_Node (SCIL_Node, N);
Insert_Action (N, SCIL_Node);
Set_SCIL_Node (N, SCIL_Node);
end if;
end if;
@ -8970,7 +8969,6 @@ package body Exp_Ch4 is
procedure Expand_Short_Circuit_Operator (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
Typ : constant Entity_Id := Etype (N);
Kind : constant Node_Kind := Nkind (N);
Left : constant Node_Id := Left_Opnd (N);
Right : constant Node_Id := Right_Opnd (N);
LocR : constant Source_Ptr := Sloc (Right);
@ -9126,18 +9124,6 @@ package body Exp_Ch4 is
Analyze_And_Resolve (Right, Standard_Boolean);
end if;
-- Special processing necessary for SCIL generation for AND THEN
-- with a function call as the right operand.
-- What is this about, and is it needed for both cases above???
if Generate_SCIL
and then Kind = N_And_Then
and then Nkind (Right) = N_Function_Call
then
Adjust_SCIL_Node (N, Right);
end if;
Adjust_Result_Type (N, Typ);
return;
end if;

14
gcc/ada/exp_ch6.adb
View File

@ -2768,20 +2768,6 @@ package body Exp_Ch6 is
Rewrite (Actual,
Unchecked_Convert_To (Parent_Typ,
Relocate_Node (Actual)));
-- If the relocated node 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 (Actual) /= N_Null
and then Nkind (Expression (Actual))
= N_Function_Call
then
Adjust_SCIL_Node (Actual, Expression (Actual));
end if;
Analyze (Actual);
Resolve (Actual, Parent_Typ);
end if;

21
gcc/ada/exp_ch7.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -54,7 +54,6 @@ 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;
@ -3566,15 +3565,6 @@ package body Exp_Ch7 is
Expr : constant Node_Id := Relocate_Node (N);
begin
-- 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 (N) = N_Function_Call
then
Adjust_SCIL_Node (N, Expr);
end if;
Insert_Actions (N, New_List (
Make_Object_Declaration (Loc,
Defining_Identifier => E,
@ -3622,15 +3612,6 @@ package body Exp_Ch7 is
New_Statement : constant Node_Id := Relocate_Node (N);
begin
-- If the relocated node is a procedure call then check if some SCIL
-- node references it and needs readjustment.
if Generate_SCIL
and then Nkind (New_Statement) = N_Procedure_Call_Statement
then
Adjust_SCIL_Node (N, New_Statement);
end if;
Rewrite (N, Make_Transient_Block (Loc, New_Statement));
-- With the scope stack back to normal, we can call analyze on the

112
gcc/ada/exp_disp.adb
View File

@ -60,6 +60,7 @@ with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
with SCIL_LL; use SCIL_LL;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
@ -578,8 +579,9 @@ package body Exp_Disp is
-- Local variables
New_Node : Node_Id;
SCIL_Node : Node_Id;
New_Node : Node_Id;
SCIL_Node : Node_Id;
SCIL_Related_Node : Node_Id := Call_Node;
-- Start of processing for Expand_Dispatching_Call
@ -649,19 +651,6 @@ package body Exp_Disp is
Typ := Non_Limited_View (Typ);
end if;
-- Generate the SCIL node for this dispatching call. The SCIL node for a
-- dispatching call is inserted in the tree before the call is rewriten
-- and expanded because the SCIL node must be found by the SCIL backend
-- BEFORE the expanded nodes associated with the call node are found.
if Generate_SCIL then
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
Eq_Prim_Op := Find_Prim_Op (Typ, Name_Op_Eq);
end if;
@ -841,12 +830,16 @@ package body Exp_Disp is
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).
-- Generate the SCIL node for this dispatching call. Done now because
-- attribute SCIL_Controlling_Tag must be set 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
SCIL_Node := Make_SCIL_Dispatching_Call (Sloc (Call_Node));
Set_SCIL_Entity (SCIL_Node, Typ);
Set_SCIL_Target_Prim (SCIL_Node, Subp);
-- Common case: the controlling tag is the tag of an object
-- (for example, obj.tag)
@ -923,15 +916,6 @@ package body Exp_Disp is
-- we generate: x.tag = y.tag and then x = y
if Subp = Eq_Prim_Op then
-- Adjust the node referenced by the SCIL node to skip the tags
-- comparison because it is the information needed by the SCIL
-- backend to process this dispatching call
if Generate_SCIL then
Set_SCIL_Related_Node (SCIL_Node, New_Call);
end if;
Param := First_Actual (Call_Node);
New_Call :=
Make_And_Then (Loc,
@ -953,6 +937,8 @@ package body Exp_Disp is
New_Reference_To
(First_Tag_Component (Typ), Loc))),
Right_Opnd => New_Call);
SCIL_Related_Node := Right_Opnd (New_Call);
end if;
else
@ -968,6 +954,12 @@ package body Exp_Disp is
Rewrite (Call_Node, New_Call);
-- Associate the SCIL node of this dispatching call
if Generate_SCIL then
Set_SCIL_Node (SCIL_Related_Node, SCIL_Node);
end if;
-- Suppress all checks during the analysis of the expanded code
-- to avoid the generation of spurious warnings under ZFP run-time.
@ -4384,17 +4376,6 @@ package body Exp_Disp is
New_Reference_To
(RTE (RE_No_Dispatch_Table_Wrapper), Loc)));
-- Generate a SCIL node for the previous object declaration
-- because it has a null dispatch table.
if Generate_SCIL then
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,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
@ -4427,9 +4408,8 @@ package body Exp_Disp is
if Generate_SCIL then
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);
Set_SCIL_Node (Last (Result), New_Node);
end if;
-- Generate:
@ -4461,17 +4441,6 @@ package body Exp_Disp is
Constraint => Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => DT_Constr_List))));
-- Generate the SCIL node for the previous object declaration
-- because it contains a dispatch table.
if Generate_SCIL then
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,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
@ -4504,9 +4473,8 @@ package body Exp_Disp is
if Generate_SCIL then
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);
Set_SCIL_Node (Last (Result), New_Node);
end if;
Append_To (Result,
@ -5274,17 +5242,6 @@ package body Exp_Disp is
Expression => Make_Aggregate (Loc,
Expressions => DT_Aggr_List)));
-- Generate the SCIL node for the previous object declaration
-- because it has a null dispatch table.
if Generate_SCIL then
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,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
@ -5585,17 +5542,6 @@ package body Exp_Disp is
Expression => Make_Aggregate (Loc,
Expressions => DT_Aggr_List)));
-- Generate the SCIL node for the previous object declaration
-- because it contains a dispatch table.
if Generate_SCIL then
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,
Make_Attribute_Definition_Clause (Loc,
Name => New_Reference_To (DT, Loc),
@ -6294,9 +6240,8 @@ package body Exp_Disp is
if Generate_SCIL then
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);
Set_SCIL_Node (Last (Result), New_Node);
end if;
Append_To (Result,
@ -6333,17 +6278,6 @@ package body Exp_Disp is
New_Occurrence_Of
(RTE_Record_Component (RE_NDT_Prims_Ptr), Loc)),
Attribute_Name => Name_Address))));
-- Generate the SCIL node for the previous object declaration
-- because it has a tag initialization.
if Generate_SCIL then
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;
Set_Is_True_Constant (DT_Ptr);

30
gcc/ada/exp_util.adb
View File

@ -43,7 +43,6 @@ 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;
@ -2812,11 +2811,9 @@ package body Exp_Util is
N_Real_Range_Specification |
N_Record_Definition |
N_Reference |
N_SCIL_Dispatch_Table_Object_Init |
N_SCIL_Dispatch_Table_Tag_Init |
N_SCIL_Dispatching_Call |
N_SCIL_Membership_Test |
N_SCIL_Tag_Init |
N_Selected_Component |
N_Signed_Integer_Type_Definition |
N_Single_Protected_Declaration |
@ -4718,15 +4715,6 @@ package body Exp_Util is
Constant_Present => True,
Expression => Relocate_Node (Exp));
-- Check if the previous node relocation requires readjustment of
-- some SCIL Dispatching node.
if Generate_SCIL
and then Nkind (Exp) = N_Function_Call
then
Adjust_SCIL_Node (Exp, Expression (E));
end if;
Set_Assignment_OK (E);
Insert_Action (Exp, E);
@ -4888,15 +4876,6 @@ package body Exp_Util is
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));
@ -4956,15 +4935,6 @@ package body Exp_Util is
Defining_Identifier => Def_Id,
Object_Definition => New_Reference_To (Ref_Type, Loc),
Expression => New_Exp));
-- Check if the previous node relocation requires readjustment
-- of some SCIL Dispatching node.
if Generate_SCIL
and then Nkind (Exp) = N_Function_Call
then
Adjust_SCIL_Node (Exp, Prefix (New_Exp));
end if;
end if;
-- Preserve the Assignment_OK flag in all copies, since at least

7
gcc/ada/frontend.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -60,6 +60,7 @@ with Sem_Warn; use Sem_Warn;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
with Sinput.L; use Sinput.L;
with SCIL_LL; use SCIL_LL;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Types; use Types;
@ -89,6 +90,10 @@ begin
Sem_Warn.Initialize;
Prep.Initialize;
if Generate_SCIL then
SCIL_LL.Initialize;
end if;
-- Create package Standard
CStand.Create_Standard;

1636
gcc/ada/gcc-interface/Make-lang.in
View File

File diff suppressed because it is too large Load Diff

2
gcc/ada/gcc-interface/Makefile.in
View File

@ -309,7 +309,7 @@ GNATMAKE_OBJS = a-except.o ali.o ali-util.o s-casuti.o \
scans.o scng.o sdefault.o sfn_scan.o s-purexc.o s-htable.o sinfo.o sinput.o \
sinput-c.o sinput-p.o snames.o stand.o stringt.o styleg.o stylesw.o system.o \
validsw.o switch.o switch-m.o table.o targparm.o tempdir.o tree_io.o types.o \
uintp.o uname.o urealp.o usage.o widechar.o \
uintp.o uname.o urealp.o usage.o widechar.o scil_ll.o \
$(EXTRA_GNATMAKE_OBJS)
# Convert the target variable into a space separated list of architecture,

130
gcc/ada/scil_ll.adb Normal file
View File

@ -0,0 +1,130 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S C I L _ L L --
-- --
-- B o d y --
-- --
-- Copyright (C) 2010, 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. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Alloc; use Alloc;
with Atree; use Atree;
with Opt; use Opt;
with Sinfo; use Sinfo;
with Table;
package body SCIL_LL is
function SCIL_Nodes_Table_Size return Pos;
-- Used to initialize the table of SCIL nodes because we do not want
-- to consume memory for this table if it is not required.
----------------------------
-- SCIL_Nodes_Table_Size --
----------------------------
function SCIL_Nodes_Table_Size return Pos is
begin
if Generate_SCIL then
return Alloc.Orig_Nodes_Initial;
else
return 1;
end if;
end SCIL_Nodes_Table_Size;
package SCIL_Nodes is new Table.Table (
Table_Component_Type => Node_Id,
Table_Index_Type => Node_Id'Base,
Table_Low_Bound => First_Node_Id,
Table_Initial => SCIL_Nodes_Table_Size,
Table_Increment => Alloc.Orig_Nodes_Increment,
Table_Name => "SCIL_Nodes");
-- This table records the value of attribute SCIL_Node of all the
-- tree nodes.
----------------
-- Initialize --
----------------
procedure Initialize is
begin
SCIL_Nodes.Init;
end Initialize;
-------------------
-- Get_SCIL_Node --
-------------------
function Get_SCIL_Node (N : Node_Id) return Node_Id is
begin
if Generate_SCIL
and then Present (N)
then
return SCIL_Nodes.Table (N);
else
return Empty;
end if;
end Get_SCIL_Node;
-------------------
-- Set_SCIL_Node --
-------------------
procedure Set_SCIL_Node (N : Node_Id; Value : Node_Id) is
begin
pragma Assert (Generate_SCIL);
if Present (Value) then
case Nkind (Value) is
when N_SCIL_Dispatch_Table_Tag_Init =>
pragma Assert (Nkind (N) = N_Object_Declaration);
null;
when N_SCIL_Dispatching_Call =>
pragma Assert (Nkind_In (N, N_Function_Call,
N_Procedure_Call_Statement));
null;
when N_SCIL_Membership_Test =>
pragma Assert (Nkind_In (N, N_Identifier,
N_And_Then,
N_Or_Else,
N_Expression_With_Actions));
null;
when others =>
pragma Assert (False);
raise Program_Error;
end case;
end if;
if Atree.Last_Node_Id > SCIL_Nodes.Last then
SCIL_Nodes.Set_Last (Atree.Last_Node_Id);
end if;
SCIL_Nodes.Set_Item (N, Value);
end Set_SCIL_Node;
end SCIL_LL;

48
gcc/ada/scil_ll.ads Normal file
View File

@ -0,0 +1,48 @@
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- S C I L _ L L --
-- --
-- S p e c --
-- --
-- Copyright (C) 2010, 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. --
-- --
-- As a special exception under Section 7 of GPL version 3, you are granted --
-- additional permissions described in the GCC Runtime Library Exception, --
-- version 3.1, as published by the Free Software Foundation. --
-- --
-- You should have received a copy of the GNU General Public License and --
-- a copy of the GCC Runtime Library Exception along with this program; --
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
-- <http://www.gnu.org/licenses/>. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
-- This package extends the tree nodes with a field that is used to reference
-- the SCIL node.
with Types; use Types;
package SCIL_LL is
function Get_SCIL_Node (N : Node_Id) return Node_Id;
-- Read the value of attribute SCIL node
procedure Set_SCIL_Node (N : Node_Id; Value : Node_Id);
-- Set the value of attribute SCIL node
procedure Initialize;
-- Initialize the table of SCIL nodes
end SCIL_LL;

8
gcc/ada/sem.adb
View File

@ -615,11 +615,9 @@ package body Sem is
-- analyzed.
when
N_SCIL_Dispatch_Table_Object_Init |
N_SCIL_Dispatch_Table_Tag_Init |
N_SCIL_Dispatching_Call |
N_SCIL_Membership_Test |
N_SCIL_Tag_Init =>
N_SCIL_Dispatch_Table_Tag_Init |
N_SCIL_Dispatching_Call |
N_SCIL_Membership_Test =>
null;
-- For the remaining node types, we generate compiler abort, because

10
gcc/ada/sem_ch4.adb
View File

@ -48,7 +48,6 @@ 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;
@ -4105,15 +4104,6 @@ package body Sem_Ch4 is
T : Entity_Id;
begin
-- Check if the expression is a function call for which we need to
-- adjust a SCIL dispatching node.
if Generate_SCIL
and then Nkind (Expr) = N_Function_Call
then
Adjust_SCIL_Node (N, Expr);
end if;
-- If Conversion_OK is set, then the Etype is already set, and the
-- only processing required is to analyze the expression. This is
-- used to construct certain "illegal" conversions which are not

10
gcc/ada/sem_ch5.adb
View File

@ -46,7 +46,6 @@ 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;
@ -1572,15 +1571,6 @@ package body Sem_Ch5 is
Name => New_Occurrence_Of (Id, Loc),
Expression => Relocate_Node (Original_Bound));
-- If the relocated node is a function call then check if some
-- SCIL node references it and needs readjustment.
if Generate_SCIL
and then Nkind (Original_Bound) = N_Function_Call
then
Adjust_SCIL_Node (Original_Bound, Expression (Assign));
end if;
Insert_Before (Parent (N), Assign);
Analyze (Assign);

97
gcc/ada/sem_ch6.adb
View File

@ -515,10 +515,10 @@ package body Sem_Ch6 is
-------------------------------------
procedure Check_Return_Subtype_Indication (Obj_Decl : Node_Id) is
Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl);
R_Stm_Type : constant Entity_Id := Etype (Return_Obj);
-- Subtype given in the extended return statement;
-- this must match R_Type.
Return_Obj : constant Node_Id := Defining_Identifier (Obj_Decl);
R_Stm_Type : constant Entity_Id := Etype (Return_Obj);
-- Subtype given in the extended return statement (must match R_Type)
Subtype_Ind : constant Node_Id :=
Object_Definition (Original_Node (Obj_Decl));
@ -543,7 +543,7 @@ package body Sem_Ch6 is
-- True if type of the return object is an anonymous access type
begin
-- First, avoid cascade errors:
-- First, avoid cascaded errors
if Error_Posted (Obj_Decl) or else Error_Posted (Subtype_Ind) then
return;
@ -1430,7 +1430,6 @@ package body Sem_Ch6 is
Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
Conformant : Boolean;
HSS : Node_Id;
Missing_Ret : Boolean;
P_Ent : Entity_Id;
Prot_Typ : Entity_Id := Empty;
Spec_Id : Entity_Id;
@ -1472,6 +1471,10 @@ package body Sem_Ch6 is
-- If pragma does not appear after the body, check whether there is
-- an inline pragma before any local declarations.
procedure Check_Missing_Return;
-- Checks for a function with a no return statements, and also performs
-- the warning checks implemented by Check_Returns.
function Disambiguate_Spec return Entity_Id;
-- When a primitive is declared between the private view and the full
-- view of a concurrent type which implements an interface, a special
@ -1664,6 +1667,46 @@ package body Sem_Ch6 is
end if;
end Check_Inline_Pragma;
--------------------------
-- Check_Missing_Return --
--------------------------
procedure Check_Missing_Return is
Id : Entity_Id;
Missing_Ret : Boolean;
begin
if Nkind (Body_Spec) = N_Function_Specification then
if Present (Spec_Id) then
Id := Spec_Id;
else
Id := Body_Id;
end if;
if Return_Present (Id) then
Check_Returns (HSS, 'F', Missing_Ret);
if Missing_Ret then
Set_Has_Missing_Return (Id);
end if;
elsif (Is_Generic_Subprogram (Id)
or else not Is_Machine_Code_Subprogram (Id))
and then not Body_Deleted
then
Error_Msg_N ("missing RETURN statement in function body", N);
end if;
-- If procedure with No_Return, check returns
elsif Nkind (Body_Spec) = N_Procedure_Specification
and then Present (Spec_Id)
and then No_Return (Spec_Id)
then
Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
end if;
end Check_Missing_Return;
-----------------------
-- Disambiguate_Spec --
-----------------------
@ -1888,6 +1931,12 @@ package body Sem_Ch6 is
Set_Is_Child_Unit (Body_Id, Is_Child_Unit (Spec_Id));
Analyze_Generic_Subprogram_Body (N, Spec_Id);
if Nkind (N) = N_Subprogram_Body then
HSS := Handled_Statement_Sequence (N);
Check_Missing_Return;
end if;
return;
else
@ -2426,41 +2475,7 @@ package body Sem_Ch6 is
end if;
end if;
-- If function, check return statements
if Nkind (Body_Spec) = N_Function_Specification then
declare
Id : Entity_Id;
begin
if Present (Spec_Id) then
Id := Spec_Id;
else
Id := Body_Id;
end if;
if Return_Present (Id) then
Check_Returns (HSS, 'F', Missing_Ret);
if Missing_Ret then
Set_Has_Missing_Return (Id);
end if;
elsif not Is_Machine_Code_Subprogram (Id)
and then not Body_Deleted
then
Error_Msg_N ("missing RETURN statement in function body", N);
end if;
end;
-- If procedure with No_Return, check returns
elsif Nkind (Body_Spec) = N_Procedure_Specification
and then Present (Spec_Id)
and then No_Return (Spec_Id)
then
Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
end if;
Check_Missing_Return;
-- Now we are going to check for variables that are never modified in
-- the body of the procedure. But first we deal with a special case

755
gcc/ada/sem_scil.adb
View File

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

12
gcc/ada/sem_scil.ads
View File

@ -4,9 +4,9 @@
-- --
-- S E M _ S C I L --
-- --
-- B o d y --
-- S p e c --
-- --
-- Copyright (C) 2009, Free Software Foundation, Inc. --
-- Copyright (C) 2009-2010, 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- --
@ -33,10 +33,6 @@ 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.
@ -44,10 +40,6 @@ package Sem_SCIL is
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

10
gcc/ada/sem_util.adb
View File

@ -50,7 +50,6 @@ 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;
@ -5450,15 +5449,6 @@ package body Sem_Util is
begin
Save_Interps (N, New_Prefix);
-- Check if the node relocation requires readjustment of some SCIL
-- dispatching node.
if Generate_SCIL
and then Nkind (N) = N_Function_Call
then
Adjust_SCIL_Node (N, New_Prefix);
end if;
Rewrite (N, Make_Explicit_Dereference (Sloc (N), Prefix => New_Prefix));
Set_Etype (N, Designated_Type (Etype (New_Prefix)));

32
gcc/ada/sinfo.adb
View File

@ -2592,26 +2592,12 @@ package body Sinfo is
(N : Node_Id) return Node_Id is
begin
pragma Assert (False
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_Membership_Test
or else NT (N).Nkind = N_SCIL_Tag_Init);
or else NT (N).Nkind = N_SCIL_Membership_Test);
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_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_Membership_Test
or else NT (N).Nkind = N_SCIL_Tag_Init);
return Node1 (N);
end SCIL_Related_Node;
function SCIL_Tag_Value
(N : Node_Id) return Node_Id is
begin
@ -5509,26 +5495,12 @@ package body Sinfo is
(N : Node_Id; Val : Node_Id) is
begin
pragma Assert (False
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_Membership_Test
or else NT (N).Nkind = N_SCIL_Tag_Init);
or else NT (N).Nkind = N_SCIL_Membership_Test);
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_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_Membership_Test
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_Tag_Value
(N : Node_Id; Val : Node_Id) is
begin

51
gcc/ada/sinfo.ads
View File

@ -1626,10 +1626,6 @@ package Sinfo is
-- Present in SCIL nodes. Used to reference the tagged type associated
-- with the SCIL node.
-- SCIL_Related_Node (Node1-Sem)
-- 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.
@ -6993,34 +6989,21 @@ package Sinfo is
-- Meanwhile these nodes should be considered in experimental form, and
-- should be ignored by all code generating back ends. ???
-- 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_Membership_Test
-- Sloc references the node of a membership test
-- SCIL_Related_Node (Node1-Sem)
-- SCIL_Tag_Value (Node5-Sem)
-- SCIL_Entity (Node4-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 --
---------------------
@ -7462,11 +7445,9 @@ package Sinfo is
-- SCIL nodes
N_SCIL_Dispatch_Table_Object_Init,
N_SCIL_Dispatch_Table_Tag_Init,
N_SCIL_Dispatching_Call,
N_SCIL_Membership_Test,
N_SCIL_Tag_Init,
-- Other nodes (not part of any subtype class)
@ -7680,8 +7661,8 @@ package Sinfo is
N_Or_Else;
subtype N_SCIL_Node is Node_Kind range
N_SCIL_Dispatch_Table_Object_Init ..
N_SCIL_Tag_Init;
N_SCIL_Dispatch_Table_Tag_Init ..
N_SCIL_Membership_Test;
subtype N_Statement_Other_Than_Procedure_Call is Node_Kind range
N_Abort_Statement ..
@ -8533,9 +8514,6 @@ package Sinfo is
function SCIL_Entity
(N : Node_Id) return Node_Id; -- Node4
function SCIL_Related_Node
(N : Node_Id) return Node_Id; -- Node1
function SCIL_Tag_Value
(N : Node_Id) return Node_Id; -- Node5
@ -9463,9 +9441,6 @@ package Sinfo is
procedure Set_SCIL_Entity
(N : Node_Id; Val : Node_Id); -- Node4
procedure Set_SCIL_Related_Node
(N : Node_Id; Val : Node_Id); -- Node1
procedure Set_SCIL_Tag_Value
(N : Node_Id; Val : Node_Id); -- Node5
@ -11226,41 +11201,27 @@ package Sinfo is
-- 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)
(1 => False, -- unused
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)
(1 => False, -- unused
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_Membership_Test =>
(1 => False, -- SCIL_Related_Node (Node1-Sem)
(1 => False, -- unused
2 => False, -- unused
3 => False, -- unused
4 => False, -- SCIL_Entity (Node4-Sem)
5 => False), -- SCIL_Tag_Value (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.
@ -11565,7 +11526,6 @@ package Sinfo is
pragma Inline (Rounded_Result);
pragma Inline (SCIL_Controlling_Tag);
pragma Inline (SCIL_Entity);
pragma Inline (SCIL_Related_Node);
pragma Inline (SCIL_Tag_Value);
pragma Inline (SCIL_Target_Prim);
pragma Inline (Scope);
@ -11871,7 +11831,6 @@ package Sinfo is
pragma Inline (Set_Rounded_Result);
pragma Inline (Set_SCIL_Controlling_Tag);
pragma Inline (Set_SCIL_Entity);
pragma Inline (Set_SCIL_Related_Node);
pragma Inline (Set_SCIL_Tag_Value);
pragma Inline (Set_SCIL_Target_Prim);
pragma Inline (Set_Scope);

6
gcc/ada/sprint.adb
View File

@ -2689,9 +2689,6 @@ package body Sprint is
-- 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]");
@ -2701,9 +2698,6 @@ package body Sprint is
when N_SCIL_Membership_Test =>
Write_Indent_Str ("[N_SCIL_Membership_Test]");
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 ");

1
gcc/ada/switch-b.adb
View File

@ -280,6 +280,7 @@ package body Switch.B is
Ptr := Ptr + 1;
Scan_Nat (Switch_Chars, Max, Ptr, Heap_Size, C);
if Heap_Size /= 32 and then Heap_Size /= 64 then
Bad_Switch (Switch_Chars);
end if;

11
gcc/ada/treepr.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2010, 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- --
@ -38,6 +38,7 @@ with Snames; use Snames;
with Sinput; use Sinput;
with Stand; use Stand;
with Stringt; use Stringt;
with SCIL_LL; use SCIL_LL;
with Treeprs; use Treeprs;
with Uintp; use Uintp;
with Urealp; use Urealp;
@ -1188,6 +1189,14 @@ package body Treepr is
Print_Entity_Info (N, Prefix_Str_Char);
end if;
-- Print the SCIL node (if available)
if Present (Get_SCIL_Node (N)) then
Print_Str (Prefix_Str_Char);
Print_Str ("SCIL_Node = ");
Print_Node_Ref (Get_SCIL_Node (N));
Print_Eol;
end if;
end Print_Node;
---------------------