Skip to content

R
riscv-gcc-1
Commit 06f2efd7 by Thomas Quinot Committed by Arnaud Charlet
Options

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
parent f27e042c
Showing with 94 additions and 29 deletions
gcc/ada/ChangeLog
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>
* g-expect.ads, g-expect.adb: Minor reformatting.
......
gcc/ada/atree.adb
......@@ -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- --
......@@ -65,6 +65,8 @@ package body Atree is
-- 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;
pragma Export (Ada, ww); -- trick the optimizer
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
-- 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 --
-----------------------------
......@@ -1237,21 +1258,7 @@ package body Atree is
begin
if Debug_Flag_N or else Node_Is_Watched then
Write_Str ("Allocate ");
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;
Node_Debug_Output ("Allocate", N);
if Node_Is_Watched then
New_Node_Breakpoint;
......@@ -1371,6 +1378,7 @@ package body Atree is
begin
return Nkind_In (Nkind (N), V1, V2, V3, V4, V5, V6, V7, V8, V9);
end Nkind_In;
--------
-- No --
--------
......@@ -1380,6 +1388,29 @@ package body Atree is
return N = Empty;
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 --
-------------------
......@@ -1564,6 +1595,7 @@ package body Atree is
(not Has_Extension (Old_Node)
and not Has_Extension (New_Node)
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
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);
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 --
------------------
......
gcc/ada/sem_res.adb
......@@ -1151,7 +1151,7 @@ package body Sem_Res is
function Operand_Type_In_Scope (S : Entity_Id) return Boolean;
-- 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.
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
-- find the type of the proper class in the given scope.
-- A final wrinkle is the multiplication operator for fixed point
-- types, which is defined in Standard only, and not in the scope of
-- the fixed_point type itself.
-- A final wrinkle is the multiplication operator for fixed point types,
-- which is defined in Standard only, and not in the scope of the
-- fixed_point type itself.
if Nkind (Name (N)) = N_Expanded_Name then
Pack := Entity (Prefix (Name (N)));
-- If the entity being called is defined in the given package,
-- it is a renaming of a predefined operator, and known to be
-- legal.
-- If the entity being called is defined in the given package, it is
-- a renaming of a predefined operator, and known to be legal.
if Scope (Entity (Name (N))) = Pack
and then Pack /= Standard_Standard
......@@ -1315,8 +1314,7 @@ package body Sem_Res is
elsif In_Instance then
null;
elsif (Op_Name = Name_Op_Multiply
or else Op_Name = Name_Op_Divide)
elsif (Op_Name = Name_Op_Multiply 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 (Right_Opnd (Op_Node)))
then
......@@ -1324,8 +1322,8 @@ package body Sem_Res is
Error := True;
end if;
-- Ada 2005, AI-420: Predefined equality on Universal_Access
-- is available.
-- Ada 2005, AI-420: Predefined equality on Universal_Access is
-- available.
elsif Ada_Version >= Ada_05
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 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
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);
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
Orig_Type := Type_In_P (Is_Composite_Type'Access);
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment