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

sem_res.adb: Minor reformatting. 

2010-06-21  Thomas Quinot  <quinot@adacore.com>

	* sem_res.adb: Minor reformatting.
	* atree.adb: New debugging hook "rr" for node rewrites.

From-SVN: r161087
This commit is contained in:
Thomas Quinot 2010-06-21 15:18:17 +00:00 committed by Arnaud Charlet
parent f27e042c9e
commit 06f2efd7ed
3 changed files with 94 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
gcc/ada/ChangeLog
View File

@ -1,3 +1,8 @@
2010-06-21 Thomas Quinot <quinot@adacore.com>
* sem_res.adb: Minor reformatting.
* atree.adb: New debugging hook "rr" for node rewrites.
2010-06-21 Robert Dewar <dewar@adacore.com> 2010-06-21 Robert Dewar <dewar@adacore.com>
* g-expect.ads, g-expect.adb: Minor reformatting. * g-expect.ads, g-expect.adb: Minor reformatting.

94
gcc/ada/atree.adb
View File

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -65,6 +65,8 @@ package body Atree is
-- The second method is faster -- The second method is faster
-- Similarly, rr and rrd allow breaking on rewriting of a given node.
ww : Node_Id'Base := Node_Id'First - 1; ww : Node_Id'Base := Node_Id'First - 1;
pragma Export (Ada, ww); -- trick the optimizer pragma Export (Ada, ww); -- trick the optimizer
Watch_Node : Node_Id'Base renames ww; Watch_Node : Node_Id'Base renames ww;
@ -89,6 +91,25 @@ package body Atree is
-- If Node = Watch_Node, this prints out the new node and calls -- If Node = Watch_Node, this prints out the new node and calls
-- New_Node_Breakpoint. Otherwise, does nothing. -- New_Node_Breakpoint. Otherwise, does nothing.
procedure rr;
pragma Export (Ada, rr);
procedure Rewrite_Breakpoint renames rr;
-- This doesn't do anything interesting; it's just for setting breakpoint
-- on as explained above.
procedure rrd (Old_Node, New_Node : Node_Id);
pragma Export (Ada, rrd);
procedure Rewrite_Debugging_Output
(Old_Node, New_Node : Node_Id) renames rrd;
-- For debugging. If debugging is turned on, Rewrite calls this. If debug
-- flag N is turned on, this prints out the new node.
--
-- If Old_Node = Watch_Node, this prints out the old and new nodes and
-- calls Rewrite_Breakpoint. Otherwise, does nothing.
procedure Node_Debug_Output (Op : String; N : Node_Id);
-- Common code for nnr and rrd. Write Op followed by information about N
----------------------------- -----------------------------
-- Local Objects and Types -- -- Local Objects and Types --
----------------------------- -----------------------------
@ -1237,21 +1258,7 @@ package body Atree is
begin begin
if Debug_Flag_N or else Node_Is_Watched then if Debug_Flag_N or else Node_Is_Watched then
Write_Str ("Allocate "); Node_Debug_Output ("Allocate", N);
if Nkind (N) in N_Entity then
Write_Str ("entity");
else
Write_Str ("node");
end if;
Write_Str (", Id = ");
Write_Int (Int (N));
Write_Str (" ");
Write_Location (Sloc (N));
Write_Str (" ");
Write_Str (Node_Kind'Image (Nkind (N)));
Write_Eol;
if Node_Is_Watched then if Node_Is_Watched then
New_Node_Breakpoint; New_Node_Breakpoint;
@ -1371,6 +1378,7 @@ package body Atree is
begin begin
return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9); return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9);
end Nkind_In; end Nkind_In;
-------- --------
-- No -- -- No --
-------- --------
@ -1380,6 +1388,29 @@ package body Atree is
return N = Empty; return N = Empty;
end No; end No;
-----------------------
-- Node_Debug_Output --
-----------------------
procedure Node_Debug_Output (Op : String; N : Node_Id) is
begin
Write_Str (Op);
if Nkind (N) in N_Entity then
Write_Str (" entity");
else
Write_Str (" node");
end if;
Write_Str (" Id = ");
Write_Int (Int (N));
Write_Str (" ");
Write_Location (Sloc (N));
Write_Str (" ");
Write_Str (Node_Kind'Image (Nkind (N)));
Write_Eol;
end Node_Debug_Output;
------------------- -------------------
-- Nodes_Address -- -- Nodes_Address --
------------------- -------------------
@ -1564,6 +1595,7 @@ package body Atree is
(not Has_Extension (Old_Node) (not Has_Extension (Old_Node)
and not Has_Extension (New_Node) and not Has_Extension (New_Node)
and not Nodes.Table (New_Node).In_List); and not Nodes.Table (New_Node).In_List);
pragma Debug (Rewrite_Debugging_Output (Old_Node, New_Node));
if Nkind (Old_Node) in N_Subexpr then if Nkind (Old_Node) in N_Subexpr then
Old_Paren_Count := Paren_Count (Old_Node); Old_Paren_Count := Paren_Count (Old_Node);
@ -1598,6 +1630,36 @@ package body Atree is
Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node); Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node);
end Rewrite; end Rewrite;
-------------------------
-- Rewrite_Breakpoint --
-------------------------
procedure rr is -- Rewrite_Breakpoint
begin
Write_Str ("Watched node ");
Write_Int (Int (Watch_Node));
Write_Str (" rewritten");
Write_Eol;
end rr;
------------------------------
-- Rewrite_Debugging_Output --
------------------------------
procedure rrd (Old_Node, New_Node : Node_Id) is -- Rewrite_Debugging_Output
Node_Is_Watched : constant Boolean := Old_Node = Watch_Node;
begin
if Debug_Flag_N or else Node_Is_Watched then
Node_Debug_Output ("Rewrite", Old_Node);
Node_Debug_Output ("into", New_Node);
if Node_Is_Watched then
Rewrite_Breakpoint;
end if;
end if;
end rrd;
------------------ ------------------
-- Set_Analyzed -- -- Set_Analyzed --
------------------ ------------------

24
gcc/ada/sem_res.adb
View File

@ -1151,7 +1151,7 @@ package body Sem_Res is
function Operand_Type_In_Scope (S : Entity_Id) return Boolean; function Operand_Type_In_Scope (S : Entity_Id) return Boolean;
-- If the operand is not universal, and the operator is given by a -- If the operand is not universal, and the operator is given by a
-- expanded name, verify that the operand has an interpretation with -- expanded name, verify that the operand has an interpretation with
-- a type defined in the given scope of the operator. -- a type defined in the given scope of the operator.
function Type_In_P (Test : Kind_Test) return Entity_Id; function Type_In_P (Test : Kind_Test) return Entity_Id;
@ -1292,16 +1292,15 @@ package body Sem_Res is
-- you courtesy of b33302a. The type itself must be frozen, so we must -- you courtesy of b33302a. The type itself must be frozen, so we must
-- find the type of the proper class in the given scope. -- find the type of the proper class in the given scope.
-- A final wrinkle is the multiplication operator for fixed point -- A final wrinkle is the multiplication operator for fixed point types,
-- types, which is defined in Standard only, and not in the scope of -- which is defined in Standard only, and not in the scope of the
-- the fixed_point type itself. -- fixed_point type itself.
if Nkind (Name (N)) = N_Expanded_Name then if Nkind (Name (N)) = N_Expanded_Name then
Pack := Entity (Prefix (Name (N))); Pack := Entity (Prefix (Name (N)));
-- If the entity being called is defined in the given package, -- If the entity being called is defined in the given package, it is
-- it is a renaming of a predefined operator, and known to be -- a renaming of a predefined operator, and known to be legal.
-- legal.
if Scope (Entity (Name (N))) = Pack if Scope (Entity (Name (N))) = Pack
and then Pack /= Standard_Standard and then Pack /= Standard_Standard
@ -1315,8 +1314,7 @@ package body Sem_Res is
elsif In_Instance then elsif In_Instance then
null; null;
elsif (Op_Name = Name_Op_Multiply elsif (Op_Name = Name_Op_Multiply or else Op_Name = Name_Op_Divide)
or else Op_Name = Name_Op_Divide)
and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node))) and then Is_Fixed_Point_Type (Etype (Left_Opnd (Op_Node)))
and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node))) and then Is_Fixed_Point_Type (Etype (Right_Opnd (Op_Node)))
then then
@ -1324,8 +1322,8 @@ package body Sem_Res is
Error := True; Error := True;
end if; end if;
-- Ada 2005, AI-420: Predefined equality on Universal_Access -- Ada 2005, AI-420: Predefined equality on Universal_Access is
-- is available. -- available.
elsif Ada_Version >= Ada_05 elsif Ada_Version >= Ada_05
and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne) and then (Op_Name = Name_Op_Eq or else Op_Name = Name_Op_Ne)
@ -1356,7 +1354,7 @@ package body Sem_Res is
if Pack /= Standard_Standard then if Pack /= Standard_Standard then
if Opnd_Type = Universal_Integer then if Opnd_Type = Universal_Integer then
Orig_Type := Type_In_P (Is_Integer_Type'Access); Orig_Type := Type_In_P (Is_Integer_Type'Access);
elsif Opnd_Type = Universal_Real then elsif Opnd_Type = Universal_Real then
Orig_Type := Type_In_P (Is_Real_Type'Access); Orig_Type := Type_In_P (Is_Real_Type'Access);
@ -1365,7 +1363,7 @@ package body Sem_Res is
Orig_Type := Type_In_P (Is_String_Type'Access); Orig_Type := Type_In_P (Is_String_Type'Access);
elsif Opnd_Type = Any_Access then elsif Opnd_Type = Any_Access then
Orig_Type := Type_In_P (Is_Definite_Access_Type'Access); Orig_Type := Type_In_P (Is_Definite_Access_Type'Access);
elsif Opnd_Type = Any_Composite then elsif Opnd_Type = Any_Composite then
Orig_Type := Type_In_P (Is_Composite_Type'Access); Orig_Type := Type_In_P (Is_Composite_Type'Access);