------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
-- --
|
-- --
|
-- GNAT COMPILER COMPONENTS --
|
-- GNAT COMPILER COMPONENTS --
|
-- --
|
-- --
|
-- T R E E P R --
|
-- T R E E P R --
|
-- --
|
-- --
|
-- B o d y --
|
-- B o d y --
|
-- --
|
-- --
|
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
|
-- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
|
-- --
|
-- --
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
-- 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- --
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
-- 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- --
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
|
-- 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 --
|
-- 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 --
|
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
-- http://www.gnu.org/licenses for a complete copy of the license. --
|
-- --
|
-- --
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
-- --
|
-- --
|
------------------------------------------------------------------------------
|
------------------------------------------------------------------------------
|
|
|
with Atree; use Atree;
|
with Atree; use Atree;
|
with Csets; use Csets;
|
with Csets; use Csets;
|
with Debug; use Debug;
|
with Debug; use Debug;
|
with Einfo; use Einfo;
|
with Einfo; use Einfo;
|
with Elists; use Elists;
|
with Elists; use Elists;
|
with Lib; use Lib;
|
with Lib; use Lib;
|
with Namet; use Namet;
|
with Namet; use Namet;
|
with Nlists; use Nlists;
|
with Nlists; use Nlists;
|
with Output; use Output;
|
with Output; use Output;
|
with Sem_Mech; use Sem_Mech;
|
with Sem_Mech; use Sem_Mech;
|
with Sinfo; use Sinfo;
|
with Sinfo; use Sinfo;
|
with Snames; use Snames;
|
with Snames; use Snames;
|
with Sinput; use Sinput;
|
with Sinput; use Sinput;
|
with Stand; use Stand;
|
with Stand; use Stand;
|
with Stringt; use Stringt;
|
with Stringt; use Stringt;
|
with Treeprs; use Treeprs;
|
with Treeprs; use Treeprs;
|
with Uintp; use Uintp;
|
with Uintp; use Uintp;
|
with Urealp; use Urealp;
|
with Urealp; use Urealp;
|
with Uname; use Uname;
|
with Uname; use Uname;
|
with Unchecked_Deallocation;
|
with Unchecked_Deallocation;
|
|
|
package body Treepr is
|
package body Treepr is
|
|
|
use Atree.Unchecked_Access;
|
use Atree.Unchecked_Access;
|
-- This module uses the unchecked access functions in package Atree
|
-- This module uses the unchecked access functions in package Atree
|
-- since it does an untyped traversal of the tree (we do not want to
|
-- since it does an untyped traversal of the tree (we do not want to
|
-- count on the structure of the tree being correct in this routine!)
|
-- count on the structure of the tree being correct in this routine!)
|
|
|
----------------------------------
|
----------------------------------
|
-- Approach Used for Tree Print --
|
-- Approach Used for Tree Print --
|
----------------------------------
|
----------------------------------
|
|
|
-- When a complete subtree is being printed, a trace phase first marks
|
-- When a complete subtree is being printed, a trace phase first marks
|
-- the nodes and lists to be printed. This trace phase allocates logical
|
-- the nodes and lists to be printed. This trace phase allocates logical
|
-- numbers corresponding to the order in which the nodes and lists will
|
-- numbers corresponding to the order in which the nodes and lists will
|
-- be printed. The Node_Id, List_Id and Elist_Id values are mapped to
|
-- be printed. The Node_Id, List_Id and Elist_Id values are mapped to
|
-- logical node numbers using a hash table. Output is done using a set
|
-- logical node numbers using a hash table. Output is done using a set
|
-- of Print_xxx routines, which are similar to the Write_xxx routines
|
-- of Print_xxx routines, which are similar to the Write_xxx routines
|
-- with the same name, except that they do not generate any output in
|
-- with the same name, except that they do not generate any output in
|
-- the marking phase. This allows identical logic to be used in the
|
-- the marking phase. This allows identical logic to be used in the
|
-- two phases.
|
-- two phases.
|
|
|
-- Note that the hash table not only holds the serial numbers, but also
|
-- Note that the hash table not only holds the serial numbers, but also
|
-- acts as a record of which nodes have already been visited. In the
|
-- acts as a record of which nodes have already been visited. In the
|
-- marking phase, a node has been visited if it is already in the hash
|
-- marking phase, a node has been visited if it is already in the hash
|
-- table, and in the printing phase, we can tell whether a node has
|
-- table, and in the printing phase, we can tell whether a node has
|
-- already been printed by looking at the value of the serial number.
|
-- already been printed by looking at the value of the serial number.
|
|
|
----------------------
|
----------------------
|
-- Global Variables --
|
-- Global Variables --
|
----------------------
|
----------------------
|
|
|
type Hash_Record is record
|
type Hash_Record is record
|
Serial : Nat;
|
Serial : Nat;
|
-- Serial number for hash table entry. A value of zero means that
|
-- Serial number for hash table entry. A value of zero means that
|
-- the entry is currently unused.
|
-- the entry is currently unused.
|
|
|
Id : Int;
|
Id : Int;
|
-- If serial number field is non-zero, contains corresponding Id value
|
-- If serial number field is non-zero, contains corresponding Id value
|
end record;
|
end record;
|
|
|
type Hash_Table_Type is array (Nat range <>) of Hash_Record;
|
type Hash_Table_Type is array (Nat range <>) of Hash_Record;
|
type Access_Hash_Table_Type is access Hash_Table_Type;
|
type Access_Hash_Table_Type is access Hash_Table_Type;
|
Hash_Table : Access_Hash_Table_Type;
|
Hash_Table : Access_Hash_Table_Type;
|
-- The hash table itself, see Serial_Number function for details of use
|
-- The hash table itself, see Serial_Number function for details of use
|
|
|
Hash_Table_Len : Nat;
|
Hash_Table_Len : Nat;
|
-- Range of Hash_Table is from 0 .. Hash_Table_Len - 1 so that dividing
|
-- Range of Hash_Table is from 0 .. Hash_Table_Len - 1 so that dividing
|
-- by Hash_Table_Len gives a remainder that is in Hash_Table'Range.
|
-- by Hash_Table_Len gives a remainder that is in Hash_Table'Range.
|
|
|
Next_Serial_Number : Nat;
|
Next_Serial_Number : Nat;
|
-- Number of last visited node or list. Used during the marking phase to
|
-- Number of last visited node or list. Used during the marking phase to
|
-- set proper node numbers in the hash table, and during the printing
|
-- set proper node numbers in the hash table, and during the printing
|
-- phase to make sure that a given node is not printed more than once.
|
-- phase to make sure that a given node is not printed more than once.
|
-- (nodes are printed in order during the printing phase, that's the
|
-- (nodes are printed in order during the printing phase, that's the
|
-- point of numbering them in the first place!)
|
-- point of numbering them in the first place!)
|
|
|
Printing_Descendants : Boolean;
|
Printing_Descendants : Boolean;
|
-- True if descendants are being printed, False if not. In the false case,
|
-- True if descendants are being printed, False if not. In the false case,
|
-- only node Id's are printed. In the true case, node numbers as well as
|
-- only node Id's are printed. In the true case, node numbers as well as
|
-- node Id's are printed, as described above.
|
-- node Id's are printed, as described above.
|
|
|
type Phase_Type is (Marking, Printing);
|
type Phase_Type is (Marking, Printing);
|
-- Type for Phase variable
|
-- Type for Phase variable
|
|
|
Phase : Phase_Type;
|
Phase : Phase_Type;
|
-- When an entire tree is being printed, the traversal operates in two
|
-- When an entire tree is being printed, the traversal operates in two
|
-- phases. The first phase marks the nodes in use by installing node
|
-- phases. The first phase marks the nodes in use by installing node
|
-- numbers in the node number table. The second phase prints the nodes.
|
-- numbers in the node number table. The second phase prints the nodes.
|
-- This variable indicates the current phase.
|
-- This variable indicates the current phase.
|
|
|
----------------------
|
----------------------
|
-- Local Procedures --
|
-- Local Procedures --
|
----------------------
|
----------------------
|
|
|
procedure Print_End_Span (N : Node_Id);
|
procedure Print_End_Span (N : Node_Id);
|
-- Special routine to print contents of End_Span field of node N.
|
-- Special routine to print contents of End_Span field of node N.
|
-- The format includes the implicit source location as well as the
|
-- The format includes the implicit source location as well as the
|
-- value of the field.
|
-- value of the field.
|
|
|
procedure Print_Init;
|
procedure Print_Init;
|
-- Initialize for printing of tree with descendents
|
-- Initialize for printing of tree with descendents
|
|
|
procedure Print_Term;
|
procedure Print_Term;
|
-- Clean up after printing of tree with descendents
|
-- Clean up after printing of tree with descendents
|
|
|
procedure Print_Char (C : Character);
|
procedure Print_Char (C : Character);
|
-- Print character C if currently in print phase, noop if in marking phase
|
-- Print character C if currently in print phase, noop if in marking phase
|
|
|
procedure Print_Name (N : Name_Id);
|
procedure Print_Name (N : Name_Id);
|
-- Print name from names table if currently in print phase, noop if in
|
-- Print name from names table if currently in print phase, noop if in
|
-- marking phase. Note that the name is output in mixed case mode.
|
-- marking phase. Note that the name is output in mixed case mode.
|
|
|
procedure Print_Node_Kind (N : Node_Id);
|
procedure Print_Node_Kind (N : Node_Id);
|
-- Print node kind name in mixed case if in print phase, noop if in
|
-- Print node kind name in mixed case if in print phase, noop if in
|
-- marking phase.
|
-- marking phase.
|
|
|
procedure Print_Str (S : String);
|
procedure Print_Str (S : String);
|
-- Print string S if currently in print phase, noop if in marking phase
|
-- Print string S if currently in print phase, noop if in marking phase
|
|
|
procedure Print_Str_Mixed_Case (S : String);
|
procedure Print_Str_Mixed_Case (S : String);
|
-- Like Print_Str, except that the string is printed in mixed case mode
|
-- Like Print_Str, except that the string is printed in mixed case mode
|
|
|
procedure Print_Int (I : Int);
|
procedure Print_Int (I : Int);
|
-- Print integer I if currently in print phase, noop if in marking phase
|
-- Print integer I if currently in print phase, noop if in marking phase
|
|
|
procedure Print_Eol;
|
procedure Print_Eol;
|
-- Print end of line if currently in print phase, noop if in marking phase
|
-- Print end of line if currently in print phase, noop if in marking phase
|
|
|
procedure Print_Node_Ref (N : Node_Id);
|
procedure Print_Node_Ref (N : Node_Id);
|
-- Print "<empty>", "<error>" or "Node #nnn" with additional information
|
-- Print "<empty>", "<error>" or "Node #nnn" with additional information
|
-- in the latter case, including the Id and the Nkind of the node.
|
-- in the latter case, including the Id and the Nkind of the node.
|
|
|
procedure Print_List_Ref (L : List_Id);
|
procedure Print_List_Ref (L : List_Id);
|
-- Print "<no list>", or "<empty node list>" or "Node list #nnn"
|
-- Print "<no list>", or "<empty node list>" or "Node list #nnn"
|
|
|
procedure Print_Elist_Ref (E : Elist_Id);
|
procedure Print_Elist_Ref (E : Elist_Id);
|
-- Print "<no elist>", or "<empty element list>" or "Element list #nnn"
|
-- Print "<no elist>", or "<empty element list>" or "Element list #nnn"
|
|
|
procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String);
|
procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String);
|
-- Called if the node being printed is an entity. Prints fields from the
|
-- Called if the node being printed is an entity. Prints fields from the
|
-- extension, using routines in Einfo to get the field names and flags.
|
-- extension, using routines in Einfo to get the field names and flags.
|
|
|
procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto);
|
procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto);
|
-- Print representation of Field value (name, tree, string, uint, charcode)
|
-- Print representation of Field value (name, tree, string, uint, charcode)
|
-- The format parameter controls the format of printing in the case of an
|
-- The format parameter controls the format of printing in the case of an
|
-- integer value (see UI_Write for details).
|
-- integer value (see UI_Write for details).
|
|
|
procedure Print_Flag (F : Boolean);
|
procedure Print_Flag (F : Boolean);
|
-- Print True or False
|
-- Print True or False
|
|
|
procedure Print_Node
|
procedure Print_Node
|
(N : Node_Id;
|
(N : Node_Id;
|
Prefix_Str : String;
|
Prefix_Str : String;
|
Prefix_Char : Character);
|
Prefix_Char : Character);
|
-- This is the internal routine used to print a single node. Each line of
|
-- This is the internal routine used to print a single node. Each line of
|
-- output is preceded by Prefix_Str (which is used to set the indentation
|
-- output is preceded by Prefix_Str (which is used to set the indentation
|
-- level and the bars used to link list elements). In addition, for lines
|
-- level and the bars used to link list elements). In addition, for lines
|
-- other than the first, an additional character Prefix_Char is output.
|
-- other than the first, an additional character Prefix_Char is output.
|
|
|
function Serial_Number (Id : Int) return Nat;
|
function Serial_Number (Id : Int) return Nat;
|
-- Given a Node_Id, List_Id or Elist_Id, returns the previously assigned
|
-- Given a Node_Id, List_Id or Elist_Id, returns the previously assigned
|
-- serial number, or zero if no serial number has yet been assigned.
|
-- serial number, or zero if no serial number has yet been assigned.
|
|
|
procedure Set_Serial_Number;
|
procedure Set_Serial_Number;
|
-- Can be called only immediately following a call to Serial_Number that
|
-- Can be called only immediately following a call to Serial_Number that
|
-- returned a value of zero. Causes the value of Next_Serial_Number to be
|
-- returned a value of zero. Causes the value of Next_Serial_Number to be
|
-- placed in the hash table (corresponding to the Id argument used in the
|
-- placed in the hash table (corresponding to the Id argument used in the
|
-- Serial_Number call), and increments Next_Serial_Number.
|
-- Serial_Number call), and increments Next_Serial_Number.
|
|
|
procedure Visit_Node
|
procedure Visit_Node
|
(N : Node_Id;
|
(N : Node_Id;
|
Prefix_Str : String;
|
Prefix_Str : String;
|
Prefix_Char : Character);
|
Prefix_Char : Character);
|
-- Called to process a single node in the case where descendents are to
|
-- Called to process a single node in the case where descendents are to
|
-- be printed before every line, and Prefix_Char added to all lines
|
-- be printed before every line, and Prefix_Char added to all lines
|
-- except the header line for the node.
|
-- except the header line for the node.
|
|
|
procedure Visit_List (L : List_Id; Prefix_Str : String);
|
procedure Visit_List (L : List_Id; Prefix_Str : String);
|
-- Visit_List is called to process a list in the case where descendents
|
-- Visit_List is called to process a list in the case where descendents
|
-- are to be printed. Prefix_Str is to be added to all printed lines.
|
-- are to be printed. Prefix_Str is to be added to all printed lines.
|
|
|
procedure Visit_Elist (E : Elist_Id; Prefix_Str : String);
|
procedure Visit_Elist (E : Elist_Id; Prefix_Str : String);
|
-- Visit_Elist is called to process an element list in the case where
|
-- Visit_Elist is called to process an element list in the case where
|
-- descendents are to be printed. Prefix_Str is to be added to all
|
-- descendents are to be printed. Prefix_Str is to be added to all
|
-- printed lines.
|
-- printed lines.
|
|
|
--------
|
--------
|
-- pe --
|
-- pe --
|
--------
|
--------
|
|
|
procedure pe (E : Elist_Id) is
|
procedure pe (E : Elist_Id) is
|
begin
|
begin
|
Print_Tree_Elist (E);
|
Print_Tree_Elist (E);
|
end pe;
|
end pe;
|
|
|
--------
|
--------
|
-- pl --
|
-- pl --
|
--------
|
--------
|
|
|
procedure pl (L : Int) is
|
procedure pl (L : Int) is
|
Lid : Int;
|
Lid : Int;
|
|
|
begin
|
begin
|
if L < 0 then
|
if L < 0 then
|
Lid := L;
|
Lid := L;
|
|
|
-- This is the case where we transform e.g. +36 to -99999936
|
-- This is the case where we transform e.g. +36 to -99999936
|
|
|
else
|
else
|
if L <= 9 then
|
if L <= 9 then
|
Lid := -(99999990 + L);
|
Lid := -(99999990 + L);
|
elsif L <= 99 then
|
elsif L <= 99 then
|
Lid := -(99999900 + L);
|
Lid := -(99999900 + L);
|
elsif L <= 999 then
|
elsif L <= 999 then
|
Lid := -(99999000 + L);
|
Lid := -(99999000 + L);
|
elsif L <= 9999 then
|
elsif L <= 9999 then
|
Lid := -(99990000 + L);
|
Lid := -(99990000 + L);
|
elsif L <= 99999 then
|
elsif L <= 99999 then
|
Lid := -(99900000 + L);
|
Lid := -(99900000 + L);
|
elsif L <= 999999 then
|
elsif L <= 999999 then
|
Lid := -(99000000 + L);
|
Lid := -(99000000 + L);
|
elsif L <= 9999999 then
|
elsif L <= 9999999 then
|
Lid := -(90000000 + L);
|
Lid := -(90000000 + L);
|
else
|
else
|
Lid := -L;
|
Lid := -L;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- Now output the list
|
-- Now output the list
|
|
|
Print_Tree_List (List_Id (Lid));
|
Print_Tree_List (List_Id (Lid));
|
end pl;
|
end pl;
|
|
|
--------
|
--------
|
-- pn --
|
-- pn --
|
--------
|
--------
|
|
|
procedure pn (N : Node_Id) is
|
procedure pn (N : Node_Id) is
|
begin
|
begin
|
Print_Tree_Node (N);
|
Print_Tree_Node (N);
|
end pn;
|
end pn;
|
|
|
----------------
|
----------------
|
-- Print_Char --
|
-- Print_Char --
|
----------------
|
----------------
|
|
|
procedure Print_Char (C : Character) is
|
procedure Print_Char (C : Character) is
|
begin
|
begin
|
if Phase = Printing then
|
if Phase = Printing then
|
Write_Char (C);
|
Write_Char (C);
|
end if;
|
end if;
|
end Print_Char;
|
end Print_Char;
|
|
|
---------------------
|
---------------------
|
-- Print_Elist_Ref --
|
-- Print_Elist_Ref --
|
---------------------
|
---------------------
|
|
|
procedure Print_Elist_Ref (E : Elist_Id) is
|
procedure Print_Elist_Ref (E : Elist_Id) is
|
begin
|
begin
|
if Phase /= Printing then
|
if Phase /= Printing then
|
return;
|
return;
|
end if;
|
end if;
|
|
|
if E = No_Elist then
|
if E = No_Elist then
|
Write_Str ("<no elist>");
|
Write_Str ("<no elist>");
|
|
|
elsif Is_Empty_Elmt_List (E) then
|
elsif Is_Empty_Elmt_List (E) then
|
Write_Str ("Empty elist, (Elist_Id=");
|
Write_Str ("Empty elist, (Elist_Id=");
|
Write_Int (Int (E));
|
Write_Int (Int (E));
|
Write_Char (')');
|
Write_Char (')');
|
|
|
else
|
else
|
Write_Str ("(Elist_Id=");
|
Write_Str ("(Elist_Id=");
|
Write_Int (Int (E));
|
Write_Int (Int (E));
|
Write_Char (')');
|
Write_Char (')');
|
|
|
if Printing_Descendants then
|
if Printing_Descendants then
|
Write_Str (" #");
|
Write_Str (" #");
|
Write_Int (Serial_Number (Int (E)));
|
Write_Int (Serial_Number (Int (E)));
|
end if;
|
end if;
|
end if;
|
end if;
|
end Print_Elist_Ref;
|
end Print_Elist_Ref;
|
|
|
-------------------------
|
-------------------------
|
-- Print_Elist_Subtree --
|
-- Print_Elist_Subtree --
|
-------------------------
|
-------------------------
|
|
|
procedure Print_Elist_Subtree (E : Elist_Id) is
|
procedure Print_Elist_Subtree (E : Elist_Id) is
|
begin
|
begin
|
Print_Init;
|
Print_Init;
|
|
|
Next_Serial_Number := 1;
|
Next_Serial_Number := 1;
|
Phase := Marking;
|
Phase := Marking;
|
Visit_Elist (E, "");
|
Visit_Elist (E, "");
|
|
|
Next_Serial_Number := 1;
|
Next_Serial_Number := 1;
|
Phase := Printing;
|
Phase := Printing;
|
Visit_Elist (E, "");
|
Visit_Elist (E, "");
|
|
|
Print_Term;
|
Print_Term;
|
end Print_Elist_Subtree;
|
end Print_Elist_Subtree;
|
|
|
--------------------
|
--------------------
|
-- Print_End_Span --
|
-- Print_End_Span --
|
--------------------
|
--------------------
|
|
|
procedure Print_End_Span (N : Node_Id) is
|
procedure Print_End_Span (N : Node_Id) is
|
Val : constant Uint := End_Span (N);
|
Val : constant Uint := End_Span (N);
|
|
|
begin
|
begin
|
UI_Write (Val);
|
UI_Write (Val);
|
Write_Str (" (Uint = ");
|
Write_Str (" (Uint = ");
|
Write_Int (Int (Field5 (N)));
|
Write_Int (Int (Field5 (N)));
|
Write_Str (") ");
|
Write_Str (") ");
|
|
|
if Val /= No_Uint then
|
if Val /= No_Uint then
|
Write_Location (End_Location (N));
|
Write_Location (End_Location (N));
|
end if;
|
end if;
|
end Print_End_Span;
|
end Print_End_Span;
|
|
|
-----------------------
|
-----------------------
|
-- Print_Entity_Info --
|
-- Print_Entity_Info --
|
-----------------------
|
-----------------------
|
|
|
procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String) is
|
procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String) is
|
function Field_Present (U : Union_Id) return Boolean;
|
function Field_Present (U : Union_Id) return Boolean;
|
-- Returns False unless the value U represents a missing value
|
-- Returns False unless the value U represents a missing value
|
-- (Empty, No_Uint, No_Ureal or No_String)
|
-- (Empty, No_Uint, No_Ureal or No_String)
|
|
|
function Field_Present (U : Union_Id) return Boolean is
|
function Field_Present (U : Union_Id) return Boolean is
|
begin
|
begin
|
return
|
return
|
U /= Union_Id (Empty) and then
|
U /= Union_Id (Empty) and then
|
U /= To_Union (No_Uint) and then
|
U /= To_Union (No_Uint) and then
|
U /= To_Union (No_Ureal) and then
|
U /= To_Union (No_Ureal) and then
|
U /= Union_Id (No_String);
|
U /= Union_Id (No_String);
|
end Field_Present;
|
end Field_Present;
|
|
|
-- Start of processing for Print_Entity_Info
|
-- Start of processing for Print_Entity_Info
|
|
|
begin
|
begin
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Print_Str ("Ekind = ");
|
Print_Str ("Ekind = ");
|
Print_Str_Mixed_Case (Entity_Kind'Image (Ekind (Ent)));
|
Print_Str_Mixed_Case (Entity_Kind'Image (Ekind (Ent)));
|
Print_Eol;
|
Print_Eol;
|
|
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Print_Str ("Etype = ");
|
Print_Str ("Etype = ");
|
Print_Node_Ref (Etype (Ent));
|
Print_Node_Ref (Etype (Ent));
|
Print_Eol;
|
Print_Eol;
|
|
|
if Convention (Ent) /= Convention_Ada then
|
if Convention (Ent) /= Convention_Ada then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Print_Str ("Convention = ");
|
Print_Str ("Convention = ");
|
|
|
-- Print convention name skipping the Convention_ at the start
|
-- Print convention name skipping the Convention_ at the start
|
|
|
declare
|
declare
|
S : constant String := Convention_Id'Image (Convention (Ent));
|
S : constant String := Convention_Id'Image (Convention (Ent));
|
|
|
begin
|
begin
|
Print_Str_Mixed_Case (S (12 .. S'Last));
|
Print_Str_Mixed_Case (S (12 .. S'Last));
|
Print_Eol;
|
Print_Eol;
|
end;
|
end;
|
end if;
|
end if;
|
|
|
if Field_Present (Field6 (Ent)) then
|
if Field_Present (Field6 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field6_Name (Ent);
|
Write_Field6_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field6 (Ent));
|
Print_Field (Field6 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field7 (Ent)) then
|
if Field_Present (Field7 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field7_Name (Ent);
|
Write_Field7_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field7 (Ent));
|
Print_Field (Field7 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field8 (Ent)) then
|
if Field_Present (Field8 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field8_Name (Ent);
|
Write_Field8_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field8 (Ent));
|
Print_Field (Field8 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field9 (Ent)) then
|
if Field_Present (Field9 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field9_Name (Ent);
|
Write_Field9_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field9 (Ent));
|
Print_Field (Field9 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field10 (Ent)) then
|
if Field_Present (Field10 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field10_Name (Ent);
|
Write_Field10_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field10 (Ent));
|
Print_Field (Field10 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field11 (Ent)) then
|
if Field_Present (Field11 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field11_Name (Ent);
|
Write_Field11_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field11 (Ent));
|
Print_Field (Field11 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field12 (Ent)) then
|
if Field_Present (Field12 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field12_Name (Ent);
|
Write_Field12_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field12 (Ent));
|
Print_Field (Field12 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field13 (Ent)) then
|
if Field_Present (Field13 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field13_Name (Ent);
|
Write_Field13_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field13 (Ent));
|
Print_Field (Field13 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field14 (Ent)) then
|
if Field_Present (Field14 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field14_Name (Ent);
|
Write_Field14_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field14 (Ent));
|
Print_Field (Field14 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field15 (Ent)) then
|
if Field_Present (Field15 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field15_Name (Ent);
|
Write_Field15_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field15 (Ent));
|
Print_Field (Field15 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field16 (Ent)) then
|
if Field_Present (Field16 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field16_Name (Ent);
|
Write_Field16_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field16 (Ent));
|
Print_Field (Field16 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field17 (Ent)) then
|
if Field_Present (Field17 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field17_Name (Ent);
|
Write_Field17_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field17 (Ent));
|
Print_Field (Field17 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field18 (Ent)) then
|
if Field_Present (Field18 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field18_Name (Ent);
|
Write_Field18_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field18 (Ent));
|
Print_Field (Field18 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field19 (Ent)) then
|
if Field_Present (Field19 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field19_Name (Ent);
|
Write_Field19_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field19 (Ent));
|
Print_Field (Field19 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field20 (Ent)) then
|
if Field_Present (Field20 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field20_Name (Ent);
|
Write_Field20_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field20 (Ent));
|
Print_Field (Field20 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field21 (Ent)) then
|
if Field_Present (Field21 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field21_Name (Ent);
|
Write_Field21_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field21 (Ent));
|
Print_Field (Field21 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field22 (Ent)) then
|
if Field_Present (Field22 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field22_Name (Ent);
|
Write_Field22_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
|
|
-- Mechanism case has to be handled specially
|
-- Mechanism case has to be handled specially
|
|
|
if Ekind (Ent) = E_Function or else Is_Formal (Ent) then
|
if Ekind (Ent) = E_Function or else Is_Formal (Ent) then
|
declare
|
declare
|
M : constant Mechanism_Type := Mechanism (Ent);
|
M : constant Mechanism_Type := Mechanism (Ent);
|
|
|
begin
|
begin
|
case M is
|
case M is
|
when Default_Mechanism
|
when Default_Mechanism
|
=> Write_Str ("Default");
|
=> Write_Str ("Default");
|
when By_Copy
|
when By_Copy
|
=> Write_Str ("By_Copy");
|
=> Write_Str ("By_Copy");
|
when By_Reference
|
when By_Reference
|
=> Write_Str ("By_Reference");
|
=> Write_Str ("By_Reference");
|
when By_Descriptor
|
when By_Descriptor
|
=> Write_Str ("By_Descriptor");
|
=> Write_Str ("By_Descriptor");
|
when By_Descriptor_UBS
|
when By_Descriptor_UBS
|
=> Write_Str ("By_Descriptor_UBS");
|
=> Write_Str ("By_Descriptor_UBS");
|
when By_Descriptor_UBSB
|
when By_Descriptor_UBSB
|
=> Write_Str ("By_Descriptor_UBSB");
|
=> Write_Str ("By_Descriptor_UBSB");
|
when By_Descriptor_UBA
|
when By_Descriptor_UBA
|
=> Write_Str ("By_Descriptor_UBA");
|
=> Write_Str ("By_Descriptor_UBA");
|
when By_Descriptor_S
|
when By_Descriptor_S
|
=> Write_Str ("By_Descriptor_S");
|
=> Write_Str ("By_Descriptor_S");
|
when By_Descriptor_SB
|
when By_Descriptor_SB
|
=> Write_Str ("By_Descriptor_SB");
|
=> Write_Str ("By_Descriptor_SB");
|
when By_Descriptor_A
|
when By_Descriptor_A
|
=> Write_Str ("By_Descriptor_A");
|
=> Write_Str ("By_Descriptor_A");
|
when By_Descriptor_NCA
|
when By_Descriptor_NCA
|
=> Write_Str ("By_Descriptor_NCA");
|
=> Write_Str ("By_Descriptor_NCA");
|
when By_Short_Descriptor
|
when By_Short_Descriptor
|
=> Write_Str ("By_Short_Descriptor");
|
=> Write_Str ("By_Short_Descriptor");
|
when By_Short_Descriptor_UBS
|
when By_Short_Descriptor_UBS
|
=> Write_Str ("By_Short_Descriptor_UBS");
|
=> Write_Str ("By_Short_Descriptor_UBS");
|
when By_Short_Descriptor_UBSB
|
when By_Short_Descriptor_UBSB
|
=> Write_Str ("By_Short_Descriptor_UBSB");
|
=> Write_Str ("By_Short_Descriptor_UBSB");
|
when By_Short_Descriptor_UBA
|
when By_Short_Descriptor_UBA
|
=> Write_Str ("By_Short_Descriptor_UBA");
|
=> Write_Str ("By_Short_Descriptor_UBA");
|
when By_Short_Descriptor_S
|
when By_Short_Descriptor_S
|
=> Write_Str ("By_Short_Descriptor_S");
|
=> Write_Str ("By_Short_Descriptor_S");
|
when By_Short_Descriptor_SB
|
when By_Short_Descriptor_SB
|
=> Write_Str ("By_Short_Descriptor_SB");
|
=> Write_Str ("By_Short_Descriptor_SB");
|
when By_Short_Descriptor_A
|
when By_Short_Descriptor_A
|
=> Write_Str ("By_Short_Descriptor_A");
|
=> Write_Str ("By_Short_Descriptor_A");
|
when By_Short_Descriptor_NCA
|
when By_Short_Descriptor_NCA
|
=> Write_Str ("By_Short_Descriptor_NCA");
|
=> Write_Str ("By_Short_Descriptor_NCA");
|
|
|
when 1 .. Mechanism_Type'Last =>
|
when 1 .. Mechanism_Type'Last =>
|
Write_Str ("By_Copy if size <= ");
|
Write_Str ("By_Copy if size <= ");
|
Write_Int (Int (M));
|
Write_Int (Int (M));
|
|
|
end case;
|
end case;
|
end;
|
end;
|
|
|
-- Normal case (not Mechanism)
|
-- Normal case (not Mechanism)
|
|
|
else
|
else
|
Print_Field (Field22 (Ent));
|
Print_Field (Field22 (Ent));
|
end if;
|
end if;
|
|
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field23 (Ent)) then
|
if Field_Present (Field23 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field23_Name (Ent);
|
Write_Field23_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field23 (Ent));
|
Print_Field (Field23 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field24 (Ent)) then
|
if Field_Present (Field24 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field24_Name (Ent);
|
Write_Field24_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field24 (Ent));
|
Print_Field (Field24 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field25 (Ent)) then
|
if Field_Present (Field25 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field25_Name (Ent);
|
Write_Field25_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field25 (Ent));
|
Print_Field (Field25 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field26 (Ent)) then
|
if Field_Present (Field26 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field26_Name (Ent);
|
Write_Field26_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field26 (Ent));
|
Print_Field (Field26 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Field_Present (Field27 (Ent)) then
|
if Field_Present (Field27 (Ent)) then
|
Print_Str (Prefix);
|
Print_Str (Prefix);
|
Write_Field27_Name (Ent);
|
Write_Field27_Name (Ent);
|
Write_Str (" = ");
|
Write_Str (" = ");
|
Print_Field (Field27 (Ent));
|
Print_Field (Field27 (Ent));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
Write_Entity_Flags (Ent, Prefix);
|
Write_Entity_Flags (Ent, Prefix);
|
end Print_Entity_Info;
|
end Print_Entity_Info;
|
|
|
---------------
|
---------------
|
-- Print_Eol --
|
-- Print_Eol --
|
---------------
|
---------------
|
|
|
procedure Print_Eol is
|
procedure Print_Eol is
|
begin
|
begin
|
if Phase = Printing then
|
if Phase = Printing then
|
Write_Eol;
|
Write_Eol;
|
end if;
|
end if;
|
end Print_Eol;
|
end Print_Eol;
|
|
|
-----------------
|
-----------------
|
-- Print_Field --
|
-- Print_Field --
|
-----------------
|
-----------------
|
|
|
procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto) is
|
procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto) is
|
begin
|
begin
|
if Phase /= Printing then
|
if Phase /= Printing then
|
return;
|
return;
|
end if;
|
end if;
|
|
|
if Val in Node_Range then
|
if Val in Node_Range then
|
Print_Node_Ref (Node_Id (Val));
|
Print_Node_Ref (Node_Id (Val));
|
|
|
elsif Val in List_Range then
|
elsif Val in List_Range then
|
Print_List_Ref (List_Id (Val));
|
Print_List_Ref (List_Id (Val));
|
|
|
elsif Val in Elist_Range then
|
elsif Val in Elist_Range then
|
Print_Elist_Ref (Elist_Id (Val));
|
Print_Elist_Ref (Elist_Id (Val));
|
|
|
elsif Val in Names_Range then
|
elsif Val in Names_Range then
|
Print_Name (Name_Id (Val));
|
Print_Name (Name_Id (Val));
|
Write_Str (" (Name_Id=");
|
Write_Str (" (Name_Id=");
|
Write_Int (Int (Val));
|
Write_Int (Int (Val));
|
Write_Char (')');
|
Write_Char (')');
|
|
|
elsif Val in Strings_Range then
|
elsif Val in Strings_Range then
|
Write_String_Table_Entry (String_Id (Val));
|
Write_String_Table_Entry (String_Id (Val));
|
Write_Str (" (String_Id=");
|
Write_Str (" (String_Id=");
|
Write_Int (Int (Val));
|
Write_Int (Int (Val));
|
Write_Char (')');
|
Write_Char (')');
|
|
|
elsif Val in Uint_Range then
|
elsif Val in Uint_Range then
|
UI_Write (From_Union (Val), Format);
|
UI_Write (From_Union (Val), Format);
|
Write_Str (" (Uint = ");
|
Write_Str (" (Uint = ");
|
Write_Int (Int (Val));
|
Write_Int (Int (Val));
|
Write_Char (')');
|
Write_Char (')');
|
|
|
elsif Val in Ureal_Range then
|
elsif Val in Ureal_Range then
|
UR_Write (From_Union (Val));
|
UR_Write (From_Union (Val));
|
Write_Str (" (Ureal = ");
|
Write_Str (" (Ureal = ");
|
Write_Int (Int (Val));
|
Write_Int (Int (Val));
|
Write_Char (')');
|
Write_Char (')');
|
|
|
else
|
else
|
Print_Str ("****** Incorrect value = ");
|
Print_Str ("****** Incorrect value = ");
|
Print_Int (Int (Val));
|
Print_Int (Int (Val));
|
end if;
|
end if;
|
end Print_Field;
|
end Print_Field;
|
|
|
----------------
|
----------------
|
-- Print_Flag --
|
-- Print_Flag --
|
----------------
|
----------------
|
|
|
procedure Print_Flag (F : Boolean) is
|
procedure Print_Flag (F : Boolean) is
|
begin
|
begin
|
if F then
|
if F then
|
Print_Str ("True");
|
Print_Str ("True");
|
else
|
else
|
Print_Str ("False");
|
Print_Str ("False");
|
end if;
|
end if;
|
end Print_Flag;
|
end Print_Flag;
|
|
|
----------------
|
----------------
|
-- Print_Init --
|
-- Print_Init --
|
----------------
|
----------------
|
|
|
procedure Print_Init is
|
procedure Print_Init is
|
begin
|
begin
|
Printing_Descendants := True;
|
Printing_Descendants := True;
|
Write_Eol;
|
Write_Eol;
|
|
|
-- Allocate and clear serial number hash table. The size is 150% of
|
-- Allocate and clear serial number hash table. The size is 150% of
|
-- the maximum possible number of entries, so that the hash table
|
-- the maximum possible number of entries, so that the hash table
|
-- cannot get significantly overloaded.
|
-- cannot get significantly overloaded.
|
|
|
Hash_Table_Len := (150 * (Num_Nodes + Num_Lists + Num_Elists)) / 100;
|
Hash_Table_Len := (150 * (Num_Nodes + Num_Lists + Num_Elists)) / 100;
|
Hash_Table := new Hash_Table_Type (0 .. Hash_Table_Len - 1);
|
Hash_Table := new Hash_Table_Type (0 .. Hash_Table_Len - 1);
|
|
|
for J in Hash_Table'Range loop
|
for J in Hash_Table'Range loop
|
Hash_Table (J).Serial := 0;
|
Hash_Table (J).Serial := 0;
|
end loop;
|
end loop;
|
|
|
end Print_Init;
|
end Print_Init;
|
|
|
---------------
|
---------------
|
-- Print_Int --
|
-- Print_Int --
|
---------------
|
---------------
|
|
|
procedure Print_Int (I : Int) is
|
procedure Print_Int (I : Int) is
|
begin
|
begin
|
if Phase = Printing then
|
if Phase = Printing then
|
Write_Int (I);
|
Write_Int (I);
|
end if;
|
end if;
|
end Print_Int;
|
end Print_Int;
|
|
|
--------------------
|
--------------------
|
-- Print_List_Ref --
|
-- Print_List_Ref --
|
--------------------
|
--------------------
|
|
|
procedure Print_List_Ref (L : List_Id) is
|
procedure Print_List_Ref (L : List_Id) is
|
begin
|
begin
|
if Phase /= Printing then
|
if Phase /= Printing then
|
return;
|
return;
|
end if;
|
end if;
|
|
|
if No (L) then
|
if No (L) then
|
Write_Str ("<no list>");
|
Write_Str ("<no list>");
|
|
|
elsif Is_Empty_List (L) then
|
elsif Is_Empty_List (L) then
|
Write_Str ("<empty list> (List_Id=");
|
Write_Str ("<empty list> (List_Id=");
|
Write_Int (Int (L));
|
Write_Int (Int (L));
|
Write_Char (')');
|
Write_Char (')');
|
|
|
else
|
else
|
Write_Str ("List");
|
Write_Str ("List");
|
|
|
if Printing_Descendants then
|
if Printing_Descendants then
|
Write_Str (" #");
|
Write_Str (" #");
|
Write_Int (Serial_Number (Int (L)));
|
Write_Int (Serial_Number (Int (L)));
|
end if;
|
end if;
|
|
|
Write_Str (" (List_Id=");
|
Write_Str (" (List_Id=");
|
Write_Int (Int (L));
|
Write_Int (Int (L));
|
Write_Char (')');
|
Write_Char (')');
|
end if;
|
end if;
|
end Print_List_Ref;
|
end Print_List_Ref;
|
|
|
------------------------
|
------------------------
|
-- Print_List_Subtree --
|
-- Print_List_Subtree --
|
------------------------
|
------------------------
|
|
|
procedure Print_List_Subtree (L : List_Id) is
|
procedure Print_List_Subtree (L : List_Id) is
|
begin
|
begin
|
Print_Init;
|
Print_Init;
|
|
|
Next_Serial_Number := 1;
|
Next_Serial_Number := 1;
|
Phase := Marking;
|
Phase := Marking;
|
Visit_List (L, "");
|
Visit_List (L, "");
|
|
|
Next_Serial_Number := 1;
|
Next_Serial_Number := 1;
|
Phase := Printing;
|
Phase := Printing;
|
Visit_List (L, "");
|
Visit_List (L, "");
|
|
|
Print_Term;
|
Print_Term;
|
end Print_List_Subtree;
|
end Print_List_Subtree;
|
|
|
----------------
|
----------------
|
-- Print_Name --
|
-- Print_Name --
|
----------------
|
----------------
|
|
|
procedure Print_Name (N : Name_Id) is
|
procedure Print_Name (N : Name_Id) is
|
begin
|
begin
|
if Phase = Printing then
|
if Phase = Printing then
|
if N = No_Name then
|
if N = No_Name then
|
Print_Str ("<No_Name>");
|
Print_Str ("<No_Name>");
|
|
|
elsif N = Error_Name then
|
elsif N = Error_Name then
|
Print_Str ("<Error_Name>");
|
Print_Str ("<Error_Name>");
|
|
|
elsif Is_Valid_Name (N) then
|
elsif Is_Valid_Name (N) then
|
Get_Name_String (N);
|
Get_Name_String (N);
|
Print_Char ('"');
|
Print_Char ('"');
|
Write_Name (N);
|
Write_Name (N);
|
Print_Char ('"');
|
Print_Char ('"');
|
|
|
else
|
else
|
Print_Str ("<invalid name ???>");
|
Print_Str ("<invalid name ???>");
|
end if;
|
end if;
|
end if;
|
end if;
|
end Print_Name;
|
end Print_Name;
|
|
|
----------------
|
----------------
|
-- Print_Node --
|
-- Print_Node --
|
----------------
|
----------------
|
|
|
procedure Print_Node
|
procedure Print_Node
|
(N : Node_Id;
|
(N : Node_Id;
|
Prefix_Str : String;
|
Prefix_Str : String;
|
Prefix_Char : Character)
|
Prefix_Char : Character)
|
is
|
is
|
F : Fchar;
|
F : Fchar;
|
P : Natural := Pchar_Pos (Nkind (N));
|
P : Natural := Pchar_Pos (Nkind (N));
|
|
|
Field_To_Be_Printed : Boolean;
|
Field_To_Be_Printed : Boolean;
|
Prefix_Str_Char : String (Prefix_Str'First .. Prefix_Str'Last + 1);
|
Prefix_Str_Char : String (Prefix_Str'First .. Prefix_Str'Last + 1);
|
|
|
Sfile : Source_File_Index;
|
Sfile : Source_File_Index;
|
Notes : Boolean;
|
Notes : Boolean;
|
Fmt : UI_Format;
|
Fmt : UI_Format;
|
|
|
begin
|
begin
|
if Phase /= Printing then
|
if Phase /= Printing then
|
return;
|
return;
|
end if;
|
end if;
|
|
|
if Nkind (N) = N_Integer_Literal and then Print_In_Hex (N) then
|
if Nkind (N) = N_Integer_Literal and then Print_In_Hex (N) then
|
Fmt := Hex;
|
Fmt := Hex;
|
else
|
else
|
Fmt := Auto;
|
Fmt := Auto;
|
end if;
|
end if;
|
|
|
Prefix_Str_Char (Prefix_Str'Range) := Prefix_Str;
|
Prefix_Str_Char (Prefix_Str'Range) := Prefix_Str;
|
Prefix_Str_Char (Prefix_Str'Last + 1) := Prefix_Char;
|
Prefix_Str_Char (Prefix_Str'Last + 1) := Prefix_Char;
|
|
|
-- Print header line
|
-- Print header line
|
|
|
Print_Str (Prefix_Str);
|
Print_Str (Prefix_Str);
|
Print_Node_Ref (N);
|
Print_Node_Ref (N);
|
|
|
Notes := False;
|
Notes := False;
|
|
|
if N > Atree_Private_Part.Nodes.Last then
|
if N > Atree_Private_Part.Nodes.Last then
|
Print_Str (" (no such node)");
|
Print_Str (" (no such node)");
|
Print_Eol;
|
Print_Eol;
|
return;
|
return;
|
end if;
|
end if;
|
|
|
if Comes_From_Source (N) then
|
if Comes_From_Source (N) then
|
Notes := True;
|
Notes := True;
|
Print_Str (" (source");
|
Print_Str (" (source");
|
end if;
|
end if;
|
|
|
if Analyzed (N) then
|
if Analyzed (N) then
|
if not Notes then
|
if not Notes then
|
Notes := True;
|
Notes := True;
|
Print_Str (" (");
|
Print_Str (" (");
|
else
|
else
|
Print_Str (",");
|
Print_Str (",");
|
end if;
|
end if;
|
|
|
Print_Str ("analyzed");
|
Print_Str ("analyzed");
|
end if;
|
end if;
|
|
|
if Error_Posted (N) then
|
if Error_Posted (N) then
|
if not Notes then
|
if not Notes then
|
Notes := True;
|
Notes := True;
|
Print_Str (" (");
|
Print_Str (" (");
|
else
|
else
|
Print_Str (",");
|
Print_Str (",");
|
end if;
|
end if;
|
|
|
Print_Str ("posted");
|
Print_Str ("posted");
|
end if;
|
end if;
|
|
|
if Notes then
|
if Notes then
|
Print_Char (')');
|
Print_Char (')');
|
end if;
|
end if;
|
|
|
Print_Eol;
|
Print_Eol;
|
|
|
if Is_Rewrite_Substitution (N) then
|
if Is_Rewrite_Substitution (N) then
|
Print_Str (Prefix_Str);
|
Print_Str (Prefix_Str);
|
Print_Str (" Rewritten: original node = ");
|
Print_Str (" Rewritten: original node = ");
|
Print_Node_Ref (Original_Node (N));
|
Print_Node_Ref (Original_Node (N));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if N = Empty then
|
if N = Empty then
|
return;
|
return;
|
end if;
|
end if;
|
|
|
if not Is_List_Member (N) then
|
if not Is_List_Member (N) then
|
Print_Str (Prefix_Str);
|
Print_Str (Prefix_Str);
|
Print_Str (" Parent = ");
|
Print_Str (" Parent = ");
|
Print_Node_Ref (Parent (N));
|
Print_Node_Ref (Parent (N));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
-- Print Sloc field if it is set
|
-- Print Sloc field if it is set
|
|
|
if Sloc (N) /= No_Location then
|
if Sloc (N) /= No_Location then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Sloc = ");
|
Print_Str ("Sloc = ");
|
|
|
if Sloc (N) = Standard_Location then
|
if Sloc (N) = Standard_Location then
|
Print_Str ("Standard_Location");
|
Print_Str ("Standard_Location");
|
|
|
elsif Sloc (N) = Standard_ASCII_Location then
|
elsif Sloc (N) = Standard_ASCII_Location then
|
Print_Str ("Standard_ASCII_Location");
|
Print_Str ("Standard_ASCII_Location");
|
|
|
else
|
else
|
Sfile := Get_Source_File_Index (Sloc (N));
|
Sfile := Get_Source_File_Index (Sloc (N));
|
Print_Int (Int (Sloc (N)) - Int (Source_Text (Sfile)'First));
|
Print_Int (Int (Sloc (N)) - Int (Source_Text (Sfile)'First));
|
Write_Str (" ");
|
Write_Str (" ");
|
Write_Location (Sloc (N));
|
Write_Location (Sloc (N));
|
end if;
|
end if;
|
|
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
-- Print Chars field if present
|
-- Print Chars field if present
|
|
|
if Nkind (N) in N_Has_Chars and then Chars (N) /= No_Name then
|
if Nkind (N) in N_Has_Chars and then Chars (N) /= No_Name then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Chars = ");
|
Print_Str ("Chars = ");
|
Print_Name (Chars (N));
|
Print_Name (Chars (N));
|
Write_Str (" (Name_Id=");
|
Write_Str (" (Name_Id=");
|
Write_Int (Int (Chars (N)));
|
Write_Int (Int (Chars (N)));
|
Write_Char (')');
|
Write_Char (')');
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
-- Special field print operations for non-entity nodes
|
-- Special field print operations for non-entity nodes
|
|
|
if Nkind (N) not in N_Entity then
|
if Nkind (N) not in N_Entity then
|
|
|
-- Deal with Left_Opnd and Right_Opnd fields
|
-- Deal with Left_Opnd and Right_Opnd fields
|
|
|
if Nkind (N) in N_Op
|
if Nkind (N) in N_Op
|
or else Nkind (N) in N_Short_Circuit
|
or else Nkind (N) in N_Short_Circuit
|
or else Nkind (N) in N_Membership_Test
|
or else Nkind (N) in N_Membership_Test
|
then
|
then
|
-- Print Left_Opnd if present
|
-- Print Left_Opnd if present
|
|
|
if Nkind (N) not in N_Unary_Op then
|
if Nkind (N) not in N_Unary_Op then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Left_Opnd = ");
|
Print_Str ("Left_Opnd = ");
|
Print_Node_Ref (Left_Opnd (N));
|
Print_Node_Ref (Left_Opnd (N));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
-- Print Right_Opnd
|
-- Print Right_Opnd
|
|
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Right_Opnd = ");
|
Print_Str ("Right_Opnd = ");
|
Print_Node_Ref (Right_Opnd (N));
|
Print_Node_Ref (Right_Opnd (N));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
-- Print Entity field if operator (other cases of Entity
|
-- Print Entity field if operator (other cases of Entity
|
-- are in the table, so are handled in the normal circuit)
|
-- are in the table, so are handled in the normal circuit)
|
|
|
if Nkind (N) in N_Op and then Present (Entity (N)) then
|
if Nkind (N) in N_Op and then Present (Entity (N)) then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Entity = ");
|
Print_Str ("Entity = ");
|
Print_Node_Ref (Entity (N));
|
Print_Node_Ref (Entity (N));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
-- Print special fields if we have a subexpression
|
-- Print special fields if we have a subexpression
|
|
|
if Nkind (N) in N_Subexpr then
|
if Nkind (N) in N_Subexpr then
|
|
|
if Assignment_OK (N) then
|
if Assignment_OK (N) then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Assignment_OK = True");
|
Print_Str ("Assignment_OK = True");
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Do_Range_Check (N) then
|
if Do_Range_Check (N) then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Do_Range_Check = True");
|
Print_Str ("Do_Range_Check = True");
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Has_Dynamic_Length_Check (N) then
|
if Has_Dynamic_Length_Check (N) then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Has_Dynamic_Length_Check = True");
|
Print_Str ("Has_Dynamic_Length_Check = True");
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Has_Dynamic_Range_Check (N) then
|
if Has_Dynamic_Range_Check (N) then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Has_Dynamic_Range_Check = True");
|
Print_Str ("Has_Dynamic_Range_Check = True");
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Is_Controlling_Actual (N) then
|
if Is_Controlling_Actual (N) then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Is_Controlling_Actual = True");
|
Print_Str ("Is_Controlling_Actual = True");
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Is_Overloaded (N) then
|
if Is_Overloaded (N) then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Is_Overloaded = True");
|
Print_Str ("Is_Overloaded = True");
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Is_Static_Expression (N) then
|
if Is_Static_Expression (N) then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Is_Static_Expression = True");
|
Print_Str ("Is_Static_Expression = True");
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Must_Not_Freeze (N) then
|
if Must_Not_Freeze (N) then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Must_Not_Freeze = True");
|
Print_Str ("Must_Not_Freeze = True");
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Paren_Count (N) /= 0 then
|
if Paren_Count (N) /= 0 then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Paren_Count = ");
|
Print_Str ("Paren_Count = ");
|
Print_Int (Int (Paren_Count (N)));
|
Print_Int (Int (Paren_Count (N)));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
if Raises_Constraint_Error (N) then
|
if Raises_Constraint_Error (N) then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Raise_Constraint_Error = True");
|
Print_Str ("Raise_Constraint_Error = True");
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
end if;
|
end if;
|
|
|
-- Print Do_Overflow_Check field if present
|
-- Print Do_Overflow_Check field if present
|
|
|
if Nkind (N) in N_Op and then Do_Overflow_Check (N) then
|
if Nkind (N) in N_Op and then Do_Overflow_Check (N) then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Do_Overflow_Check = True");
|
Print_Str ("Do_Overflow_Check = True");
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
-- Print Etype field if present (printing of this field for entities
|
-- Print Etype field if present (printing of this field for entities
|
-- is handled by the Print_Entity_Info procedure).
|
-- is handled by the Print_Entity_Info procedure).
|
|
|
if Nkind (N) in N_Has_Etype and then Present (Etype (N)) then
|
if Nkind (N) in N_Has_Etype and then Present (Etype (N)) then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
Print_Str ("Etype = ");
|
Print_Str ("Etype = ");
|
Print_Node_Ref (Etype (N));
|
Print_Node_Ref (Etype (N));
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- Loop to print fields included in Pchars array
|
-- Loop to print fields included in Pchars array
|
|
|
while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) loop
|
while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) loop
|
F := Pchars (P);
|
F := Pchars (P);
|
P := P + 1;
|
P := P + 1;
|
|
|
-- Check for case of False flag, which we never print, or
|
-- Check for case of False flag, which we never print, or
|
-- an Empty field, which is also never printed
|
-- an Empty field, which is also never printed
|
|
|
case F is
|
case F is
|
when F_Field1 =>
|
when F_Field1 =>
|
Field_To_Be_Printed := Field1 (N) /= Union_Id (Empty);
|
Field_To_Be_Printed := Field1 (N) /= Union_Id (Empty);
|
|
|
when F_Field2 =>
|
when F_Field2 =>
|
Field_To_Be_Printed := Field2 (N) /= Union_Id (Empty);
|
Field_To_Be_Printed := Field2 (N) /= Union_Id (Empty);
|
|
|
when F_Field3 =>
|
when F_Field3 =>
|
Field_To_Be_Printed := Field3 (N) /= Union_Id (Empty);
|
Field_To_Be_Printed := Field3 (N) /= Union_Id (Empty);
|
|
|
when F_Field4 =>
|
when F_Field4 =>
|
Field_To_Be_Printed := Field4 (N) /= Union_Id (Empty);
|
Field_To_Be_Printed := Field4 (N) /= Union_Id (Empty);
|
|
|
when F_Field5 =>
|
when F_Field5 =>
|
Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty);
|
Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty);
|
|
|
when F_Flag4 => Field_To_Be_Printed := Flag4 (N);
|
when F_Flag4 => Field_To_Be_Printed := Flag4 (N);
|
when F_Flag5 => Field_To_Be_Printed := Flag5 (N);
|
when F_Flag5 => Field_To_Be_Printed := Flag5 (N);
|
when F_Flag6 => Field_To_Be_Printed := Flag6 (N);
|
when F_Flag6 => Field_To_Be_Printed := Flag6 (N);
|
when F_Flag7 => Field_To_Be_Printed := Flag7 (N);
|
when F_Flag7 => Field_To_Be_Printed := Flag7 (N);
|
when F_Flag8 => Field_To_Be_Printed := Flag8 (N);
|
when F_Flag8 => Field_To_Be_Printed := Flag8 (N);
|
when F_Flag9 => Field_To_Be_Printed := Flag9 (N);
|
when F_Flag9 => Field_To_Be_Printed := Flag9 (N);
|
when F_Flag10 => Field_To_Be_Printed := Flag10 (N);
|
when F_Flag10 => Field_To_Be_Printed := Flag10 (N);
|
when F_Flag11 => Field_To_Be_Printed := Flag11 (N);
|
when F_Flag11 => Field_To_Be_Printed := Flag11 (N);
|
when F_Flag12 => Field_To_Be_Printed := Flag12 (N);
|
when F_Flag12 => Field_To_Be_Printed := Flag12 (N);
|
when F_Flag13 => Field_To_Be_Printed := Flag13 (N);
|
when F_Flag13 => Field_To_Be_Printed := Flag13 (N);
|
when F_Flag14 => Field_To_Be_Printed := Flag14 (N);
|
when F_Flag14 => Field_To_Be_Printed := Flag14 (N);
|
when F_Flag15 => Field_To_Be_Printed := Flag15 (N);
|
when F_Flag15 => Field_To_Be_Printed := Flag15 (N);
|
when F_Flag16 => Field_To_Be_Printed := Flag16 (N);
|
when F_Flag16 => Field_To_Be_Printed := Flag16 (N);
|
when F_Flag17 => Field_To_Be_Printed := Flag17 (N);
|
when F_Flag17 => Field_To_Be_Printed := Flag17 (N);
|
when F_Flag18 => Field_To_Be_Printed := Flag18 (N);
|
when F_Flag18 => Field_To_Be_Printed := Flag18 (N);
|
|
|
-- Flag1,2,3 are no longer used
|
-- Flag1,2,3 are no longer used
|
|
|
when F_Flag1 => raise Program_Error;
|
when F_Flag1 => raise Program_Error;
|
when F_Flag2 => raise Program_Error;
|
when F_Flag2 => raise Program_Error;
|
when F_Flag3 => raise Program_Error;
|
when F_Flag3 => raise Program_Error;
|
|
|
end case;
|
end case;
|
|
|
-- Print field if it is to be printed
|
-- Print field if it is to be printed
|
|
|
if Field_To_Be_Printed then
|
if Field_To_Be_Printed then
|
Print_Str (Prefix_Str_Char);
|
Print_Str (Prefix_Str_Char);
|
|
|
while P < Pchar_Pos (Node_Kind'Succ (Nkind (N)))
|
while P < Pchar_Pos (Node_Kind'Succ (Nkind (N)))
|
and then Pchars (P) not in Fchar
|
and then Pchars (P) not in Fchar
|
loop
|
loop
|
Print_Char (Pchars (P));
|
Print_Char (Pchars (P));
|
P := P + 1;
|
P := P + 1;
|
end loop;
|
end loop;
|
|
|
Print_Str (" = ");
|
Print_Str (" = ");
|
|
|
case F is
|
case F is
|
when F_Field1 => Print_Field (Field1 (N), Fmt);
|
when F_Field1 => Print_Field (Field1 (N), Fmt);
|
when F_Field2 => Print_Field (Field2 (N), Fmt);
|
when F_Field2 => Print_Field (Field2 (N), Fmt);
|
when F_Field3 => Print_Field (Field3 (N), Fmt);
|
when F_Field3 => Print_Field (Field3 (N), Fmt);
|
when F_Field4 => Print_Field (Field4 (N), Fmt);
|
when F_Field4 => Print_Field (Field4 (N), Fmt);
|
|
|
-- Special case End_Span = Uint5
|
-- Special case End_Span = Uint5
|
|
|
when F_Field5 =>
|
when F_Field5 =>
|
if Nkind (N) = N_Case_Statement
|
if Nkind (N) = N_Case_Statement
|
or else Nkind (N) = N_If_Statement
|
or else Nkind (N) = N_If_Statement
|
then
|
then
|
Print_End_Span (N);
|
Print_End_Span (N);
|
else
|
else
|
Print_Field (Field5 (N), Fmt);
|
Print_Field (Field5 (N), Fmt);
|
end if;
|
end if;
|
|
|
when F_Flag4 => Print_Flag (Flag4 (N));
|
when F_Flag4 => Print_Flag (Flag4 (N));
|
when F_Flag5 => Print_Flag (Flag5 (N));
|
when F_Flag5 => Print_Flag (Flag5 (N));
|
when F_Flag6 => Print_Flag (Flag6 (N));
|
when F_Flag6 => Print_Flag (Flag6 (N));
|
when F_Flag7 => Print_Flag (Flag7 (N));
|
when F_Flag7 => Print_Flag (Flag7 (N));
|
when F_Flag8 => Print_Flag (Flag8 (N));
|
when F_Flag8 => Print_Flag (Flag8 (N));
|
when F_Flag9 => Print_Flag (Flag9 (N));
|
when F_Flag9 => Print_Flag (Flag9 (N));
|
when F_Flag10 => Print_Flag (Flag10 (N));
|
when F_Flag10 => Print_Flag (Flag10 (N));
|
when F_Flag11 => Print_Flag (Flag11 (N));
|
when F_Flag11 => Print_Flag (Flag11 (N));
|
when F_Flag12 => Print_Flag (Flag12 (N));
|
when F_Flag12 => Print_Flag (Flag12 (N));
|
when F_Flag13 => Print_Flag (Flag13 (N));
|
when F_Flag13 => Print_Flag (Flag13 (N));
|
when F_Flag14 => Print_Flag (Flag14 (N));
|
when F_Flag14 => Print_Flag (Flag14 (N));
|
when F_Flag15 => Print_Flag (Flag15 (N));
|
when F_Flag15 => Print_Flag (Flag15 (N));
|
when F_Flag16 => Print_Flag (Flag16 (N));
|
when F_Flag16 => Print_Flag (Flag16 (N));
|
when F_Flag17 => Print_Flag (Flag17 (N));
|
when F_Flag17 => Print_Flag (Flag17 (N));
|
when F_Flag18 => Print_Flag (Flag18 (N));
|
when F_Flag18 => Print_Flag (Flag18 (N));
|
|
|
-- Flag1,2,3 are no longer used
|
-- Flag1,2,3 are no longer used
|
|
|
when F_Flag1 => raise Program_Error;
|
when F_Flag1 => raise Program_Error;
|
when F_Flag2 => raise Program_Error;
|
when F_Flag2 => raise Program_Error;
|
when F_Flag3 => raise Program_Error;
|
when F_Flag3 => raise Program_Error;
|
end case;
|
end case;
|
|
|
Print_Eol;
|
Print_Eol;
|
|
|
-- Field is not to be printed (False flag field)
|
-- Field is not to be printed (False flag field)
|
|
|
else
|
else
|
while P < Pchar_Pos (Node_Kind'Succ (Nkind (N)))
|
while P < Pchar_Pos (Node_Kind'Succ (Nkind (N)))
|
and then Pchars (P) not in Fchar
|
and then Pchars (P) not in Fchar
|
loop
|
loop
|
P := P + 1;
|
P := P + 1;
|
end loop;
|
end loop;
|
end if;
|
end if;
|
|
|
end loop;
|
end loop;
|
|
|
-- Print entity information for entities
|
-- Print entity information for entities
|
|
|
if Nkind (N) in N_Entity then
|
if Nkind (N) in N_Entity then
|
Print_Entity_Info (N, Prefix_Str_Char);
|
Print_Entity_Info (N, Prefix_Str_Char);
|
end if;
|
end if;
|
|
|
end Print_Node;
|
end Print_Node;
|
|
|
---------------------
|
---------------------
|
-- Print_Node_Kind --
|
-- Print_Node_Kind --
|
---------------------
|
---------------------
|
|
|
procedure Print_Node_Kind (N : Node_Id) is
|
procedure Print_Node_Kind (N : Node_Id) is
|
Ucase : Boolean;
|
Ucase : Boolean;
|
S : constant String := Node_Kind'Image (Nkind (N));
|
S : constant String := Node_Kind'Image (Nkind (N));
|
|
|
begin
|
begin
|
if Phase = Printing then
|
if Phase = Printing then
|
Ucase := True;
|
Ucase := True;
|
|
|
-- Note: the call to Fold_Upper in this loop is to get past the GNAT
|
-- Note: the call to Fold_Upper in this loop is to get past the GNAT
|
-- bug of 'Image returning lower case instead of upper case.
|
-- bug of 'Image returning lower case instead of upper case.
|
|
|
for J in S'Range loop
|
for J in S'Range loop
|
if Ucase then
|
if Ucase then
|
Write_Char (Fold_Upper (S (J)));
|
Write_Char (Fold_Upper (S (J)));
|
else
|
else
|
Write_Char (Fold_Lower (S (J)));
|
Write_Char (Fold_Lower (S (J)));
|
end if;
|
end if;
|
|
|
Ucase := (S (J) = '_');
|
Ucase := (S (J) = '_');
|
end loop;
|
end loop;
|
end if;
|
end if;
|
end Print_Node_Kind;
|
end Print_Node_Kind;
|
|
|
--------------------
|
--------------------
|
-- Print_Node_Ref --
|
-- Print_Node_Ref --
|
--------------------
|
--------------------
|
|
|
procedure Print_Node_Ref (N : Node_Id) is
|
procedure Print_Node_Ref (N : Node_Id) is
|
S : Nat;
|
S : Nat;
|
|
|
begin
|
begin
|
if Phase /= Printing then
|
if Phase /= Printing then
|
return;
|
return;
|
end if;
|
end if;
|
|
|
if N = Empty then
|
if N = Empty then
|
Write_Str ("<empty>");
|
Write_Str ("<empty>");
|
|
|
elsif N = Error then
|
elsif N = Error then
|
Write_Str ("<error>");
|
Write_Str ("<error>");
|
|
|
else
|
else
|
if Printing_Descendants then
|
if Printing_Descendants then
|
S := Serial_Number (Int (N));
|
S := Serial_Number (Int (N));
|
|
|
if S /= 0 then
|
if S /= 0 then
|
Write_Str ("Node");
|
Write_Str ("Node");
|
Write_Str (" #");
|
Write_Str (" #");
|
Write_Int (S);
|
Write_Int (S);
|
Write_Char (' ');
|
Write_Char (' ');
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
Print_Node_Kind (N);
|
Print_Node_Kind (N);
|
|
|
if Nkind (N) in N_Has_Chars then
|
if Nkind (N) in N_Has_Chars then
|
Write_Char (' ');
|
Write_Char (' ');
|
Print_Name (Chars (N));
|
Print_Name (Chars (N));
|
end if;
|
end if;
|
|
|
if Nkind (N) in N_Entity then
|
if Nkind (N) in N_Entity then
|
Write_Str (" (Entity_Id=");
|
Write_Str (" (Entity_Id=");
|
else
|
else
|
Write_Str (" (Node_Id=");
|
Write_Str (" (Node_Id=");
|
end if;
|
end if;
|
|
|
Write_Int (Int (N));
|
Write_Int (Int (N));
|
|
|
if Sloc (N) <= Standard_Location then
|
if Sloc (N) <= Standard_Location then
|
Write_Char ('s');
|
Write_Char ('s');
|
end if;
|
end if;
|
|
|
Write_Char (')');
|
Write_Char (')');
|
|
|
end if;
|
end if;
|
end Print_Node_Ref;
|
end Print_Node_Ref;
|
|
|
------------------------
|
------------------------
|
-- Print_Node_Subtree --
|
-- Print_Node_Subtree --
|
------------------------
|
------------------------
|
|
|
procedure Print_Node_Subtree (N : Node_Id) is
|
procedure Print_Node_Subtree (N : Node_Id) is
|
begin
|
begin
|
Print_Init;
|
Print_Init;
|
|
|
Next_Serial_Number := 1;
|
Next_Serial_Number := 1;
|
Phase := Marking;
|
Phase := Marking;
|
Visit_Node (N, "", ' ');
|
Visit_Node (N, "", ' ');
|
|
|
Next_Serial_Number := 1;
|
Next_Serial_Number := 1;
|
Phase := Printing;
|
Phase := Printing;
|
Visit_Node (N, "", ' ');
|
Visit_Node (N, "", ' ');
|
|
|
Print_Term;
|
Print_Term;
|
end Print_Node_Subtree;
|
end Print_Node_Subtree;
|
|
|
---------------
|
---------------
|
-- Print_Str --
|
-- Print_Str --
|
---------------
|
---------------
|
|
|
procedure Print_Str (S : String) is
|
procedure Print_Str (S : String) is
|
begin
|
begin
|
if Phase = Printing then
|
if Phase = Printing then
|
Write_Str (S);
|
Write_Str (S);
|
end if;
|
end if;
|
end Print_Str;
|
end Print_Str;
|
|
|
--------------------------
|
--------------------------
|
-- Print_Str_Mixed_Case --
|
-- Print_Str_Mixed_Case --
|
--------------------------
|
--------------------------
|
|
|
procedure Print_Str_Mixed_Case (S : String) is
|
procedure Print_Str_Mixed_Case (S : String) is
|
Ucase : Boolean;
|
Ucase : Boolean;
|
|
|
begin
|
begin
|
if Phase = Printing then
|
if Phase = Printing then
|
Ucase := True;
|
Ucase := True;
|
|
|
for J in S'Range loop
|
for J in S'Range loop
|
if Ucase then
|
if Ucase then
|
Write_Char (S (J));
|
Write_Char (S (J));
|
else
|
else
|
Write_Char (Fold_Lower (S (J)));
|
Write_Char (Fold_Lower (S (J)));
|
end if;
|
end if;
|
|
|
Ucase := (S (J) = '_');
|
Ucase := (S (J) = '_');
|
end loop;
|
end loop;
|
end if;
|
end if;
|
end Print_Str_Mixed_Case;
|
end Print_Str_Mixed_Case;
|
|
|
----------------
|
----------------
|
-- Print_Term --
|
-- Print_Term --
|
----------------
|
----------------
|
|
|
procedure Print_Term is
|
procedure Print_Term is
|
procedure Free is new Unchecked_Deallocation
|
procedure Free is new Unchecked_Deallocation
|
(Hash_Table_Type, Access_Hash_Table_Type);
|
(Hash_Table_Type, Access_Hash_Table_Type);
|
|
|
begin
|
begin
|
Free (Hash_Table);
|
Free (Hash_Table);
|
end Print_Term;
|
end Print_Term;
|
|
|
---------------------
|
---------------------
|
-- Print_Tree_Elist --
|
-- Print_Tree_Elist --
|
---------------------
|
---------------------
|
|
|
procedure Print_Tree_Elist (E : Elist_Id) is
|
procedure Print_Tree_Elist (E : Elist_Id) is
|
M : Elmt_Id;
|
M : Elmt_Id;
|
|
|
begin
|
begin
|
Printing_Descendants := False;
|
Printing_Descendants := False;
|
Phase := Printing;
|
Phase := Printing;
|
|
|
Print_Elist_Ref (E);
|
Print_Elist_Ref (E);
|
Print_Eol;
|
Print_Eol;
|
|
|
M := First_Elmt (E);
|
M := First_Elmt (E);
|
|
|
if No (M) then
|
if No (M) then
|
Print_Str ("<empty element list>");
|
Print_Str ("<empty element list>");
|
Print_Eol;
|
Print_Eol;
|
|
|
else
|
else
|
loop
|
loop
|
Print_Char ('|');
|
Print_Char ('|');
|
Print_Eol;
|
Print_Eol;
|
exit when No (Next_Elmt (M));
|
exit when No (Next_Elmt (M));
|
Print_Node (Node (M), "", '|');
|
Print_Node (Node (M), "", '|');
|
Next_Elmt (M);
|
Next_Elmt (M);
|
end loop;
|
end loop;
|
|
|
Print_Node (Node (M), "", ' ');
|
Print_Node (Node (M), "", ' ');
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
end Print_Tree_Elist;
|
end Print_Tree_Elist;
|
|
|
---------------------
|
---------------------
|
-- Print_Tree_List --
|
-- Print_Tree_List --
|
---------------------
|
---------------------
|
|
|
procedure Print_Tree_List (L : List_Id) is
|
procedure Print_Tree_List (L : List_Id) is
|
N : Node_Id;
|
N : Node_Id;
|
|
|
begin
|
begin
|
Printing_Descendants := False;
|
Printing_Descendants := False;
|
Phase := Printing;
|
Phase := Printing;
|
|
|
Print_List_Ref (L);
|
Print_List_Ref (L);
|
Print_Str (" List_Id=");
|
Print_Str (" List_Id=");
|
Print_Int (Int (L));
|
Print_Int (Int (L));
|
Print_Eol;
|
Print_Eol;
|
|
|
N := First (L);
|
N := First (L);
|
|
|
if N = Empty then
|
if N = Empty then
|
Print_Str ("<empty node list>");
|
Print_Str ("<empty node list>");
|
Print_Eol;
|
Print_Eol;
|
|
|
else
|
else
|
loop
|
loop
|
Print_Char ('|');
|
Print_Char ('|');
|
Print_Eol;
|
Print_Eol;
|
exit when Next (N) = Empty;
|
exit when Next (N) = Empty;
|
Print_Node (N, "", '|');
|
Print_Node (N, "", '|');
|
Next (N);
|
Next (N);
|
end loop;
|
end loop;
|
|
|
Print_Node (N, "", ' ');
|
Print_Node (N, "", ' ');
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
end Print_Tree_List;
|
end Print_Tree_List;
|
|
|
---------------------
|
---------------------
|
-- Print_Tree_Node --
|
-- Print_Tree_Node --
|
---------------------
|
---------------------
|
|
|
procedure Print_Tree_Node (N : Node_Id; Label : String := "") is
|
procedure Print_Tree_Node (N : Node_Id; Label : String := "") is
|
begin
|
begin
|
Printing_Descendants := False;
|
Printing_Descendants := False;
|
Phase := Printing;
|
Phase := Printing;
|
Print_Node (N, Label, ' ');
|
Print_Node (N, Label, ' ');
|
end Print_Tree_Node;
|
end Print_Tree_Node;
|
|
|
--------
|
--------
|
-- pt --
|
-- pt --
|
--------
|
--------
|
|
|
procedure pt (N : Node_Id) is
|
procedure pt (N : Node_Id) is
|
begin
|
begin
|
Print_Node_Subtree (N);
|
Print_Node_Subtree (N);
|
end pt;
|
end pt;
|
|
|
-------------------
|
-------------------
|
-- Serial_Number --
|
-- Serial_Number --
|
-------------------
|
-------------------
|
|
|
-- The hashing algorithm is to use the remainder of the ID value divided
|
-- The hashing algorithm is to use the remainder of the ID value divided
|
-- by the hash table length as the starting point in the table, and then
|
-- by the hash table length as the starting point in the table, and then
|
-- handle collisions by serial searching wrapping at the end of the table.
|
-- handle collisions by serial searching wrapping at the end of the table.
|
|
|
Hash_Slot : Nat;
|
Hash_Slot : Nat;
|
-- Set by an unsuccessful call to Serial_Number (one which returns zero)
|
-- Set by an unsuccessful call to Serial_Number (one which returns zero)
|
-- to save the slot that should be used if Set_Serial_Number is called.
|
-- to save the slot that should be used if Set_Serial_Number is called.
|
|
|
function Serial_Number (Id : Int) return Nat is
|
function Serial_Number (Id : Int) return Nat is
|
H : Int := Id mod Hash_Table_Len;
|
H : Int := Id mod Hash_Table_Len;
|
|
|
begin
|
begin
|
while Hash_Table (H).Serial /= 0 loop
|
while Hash_Table (H).Serial /= 0 loop
|
|
|
if Id = Hash_Table (H).Id then
|
if Id = Hash_Table (H).Id then
|
return Hash_Table (H).Serial;
|
return Hash_Table (H).Serial;
|
end if;
|
end if;
|
|
|
H := H + 1;
|
H := H + 1;
|
|
|
if H > Hash_Table'Last then
|
if H > Hash_Table'Last then
|
H := 0;
|
H := 0;
|
end if;
|
end if;
|
end loop;
|
end loop;
|
|
|
-- Entry was not found, save slot number for possible subsequent call
|
-- Entry was not found, save slot number for possible subsequent call
|
-- to Set_Serial_Number, and unconditionally save the Id in this slot
|
-- to Set_Serial_Number, and unconditionally save the Id in this slot
|
-- in case of such a call (the Id field is never read if the serial
|
-- in case of such a call (the Id field is never read if the serial
|
-- number of the slot is zero, so this is harmless in the case where
|
-- number of the slot is zero, so this is harmless in the case where
|
-- Set_Serial_Number is not subsequently called).
|
-- Set_Serial_Number is not subsequently called).
|
|
|
Hash_Slot := H;
|
Hash_Slot := H;
|
Hash_Table (H).Id := Id;
|
Hash_Table (H).Id := Id;
|
return 0;
|
return 0;
|
|
|
end Serial_Number;
|
end Serial_Number;
|
|
|
-----------------------
|
-----------------------
|
-- Set_Serial_Number --
|
-- Set_Serial_Number --
|
-----------------------
|
-----------------------
|
|
|
procedure Set_Serial_Number is
|
procedure Set_Serial_Number is
|
begin
|
begin
|
Hash_Table (Hash_Slot).Serial := Next_Serial_Number;
|
Hash_Table (Hash_Slot).Serial := Next_Serial_Number;
|
Next_Serial_Number := Next_Serial_Number + 1;
|
Next_Serial_Number := Next_Serial_Number + 1;
|
end Set_Serial_Number;
|
end Set_Serial_Number;
|
|
|
---------------
|
---------------
|
-- Tree_Dump --
|
-- Tree_Dump --
|
---------------
|
---------------
|
|
|
procedure Tree_Dump is
|
procedure Tree_Dump is
|
procedure Underline;
|
procedure Underline;
|
-- Put underline under string we just printed
|
-- Put underline under string we just printed
|
|
|
procedure Underline is
|
procedure Underline is
|
Col : constant Int := Column;
|
Col : constant Int := Column;
|
|
|
begin
|
begin
|
Write_Eol;
|
Write_Eol;
|
|
|
while Col > Column loop
|
while Col > Column loop
|
Write_Char ('-');
|
Write_Char ('-');
|
end loop;
|
end loop;
|
|
|
Write_Eol;
|
Write_Eol;
|
end Underline;
|
end Underline;
|
|
|
-- Start of processing for Tree_Dump. Note that we turn off the tree dump
|
-- Start of processing for Tree_Dump. Note that we turn off the tree dump
|
-- flags immediately, before starting the dump. This avoids generating two
|
-- flags immediately, before starting the dump. This avoids generating two
|
-- copies of the dump if an abort occurs after printing the dump, and more
|
-- copies of the dump if an abort occurs after printing the dump, and more
|
-- importantly, avoids an infinite loop if an abort occurs during the dump.
|
-- importantly, avoids an infinite loop if an abort occurs during the dump.
|
|
|
-- Note: unlike in the source print case (in Sprint), we do not output
|
-- Note: unlike in the source print case (in Sprint), we do not output
|
-- separate trees for each unit. Instead the -df debug switch causes the
|
-- separate trees for each unit. Instead the -df debug switch causes the
|
-- tree that is output from the main unit to trace references into other
|
-- tree that is output from the main unit to trace references into other
|
-- units (normally such references are not traced). Since all other units
|
-- units (normally such references are not traced). Since all other units
|
-- are linked to the main unit by at least one reference, this causes all
|
-- are linked to the main unit by at least one reference, this causes all
|
-- tree nodes to be included in the output tree.
|
-- tree nodes to be included in the output tree.
|
|
|
begin
|
begin
|
if Debug_Flag_Y then
|
if Debug_Flag_Y then
|
Debug_Flag_Y := False;
|
Debug_Flag_Y := False;
|
Write_Eol;
|
Write_Eol;
|
Write_Str ("Tree created for Standard (spec) ");
|
Write_Str ("Tree created for Standard (spec) ");
|
Underline;
|
Underline;
|
Print_Node_Subtree (Standard_Package_Node);
|
Print_Node_Subtree (Standard_Package_Node);
|
Write_Eol;
|
Write_Eol;
|
end if;
|
end if;
|
|
|
if Debug_Flag_T then
|
if Debug_Flag_T then
|
Debug_Flag_T := False;
|
Debug_Flag_T := False;
|
|
|
Write_Eol;
|
Write_Eol;
|
Write_Str ("Tree created for ");
|
Write_Str ("Tree created for ");
|
Write_Unit_Name (Unit_Name (Main_Unit));
|
Write_Unit_Name (Unit_Name (Main_Unit));
|
Underline;
|
Underline;
|
Print_Node_Subtree (Cunit (Main_Unit));
|
Print_Node_Subtree (Cunit (Main_Unit));
|
Write_Eol;
|
Write_Eol;
|
end if;
|
end if;
|
|
|
end Tree_Dump;
|
end Tree_Dump;
|
|
|
-----------------
|
-----------------
|
-- Visit_Elist --
|
-- Visit_Elist --
|
-----------------
|
-----------------
|
|
|
procedure Visit_Elist (E : Elist_Id; Prefix_Str : String) is
|
procedure Visit_Elist (E : Elist_Id; Prefix_Str : String) is
|
M : Elmt_Id;
|
M : Elmt_Id;
|
N : Node_Id;
|
N : Node_Id;
|
S : constant Nat := Serial_Number (Int (E));
|
S : constant Nat := Serial_Number (Int (E));
|
|
|
begin
|
begin
|
-- In marking phase, return if already marked, otherwise set next
|
-- In marking phase, return if already marked, otherwise set next
|
-- serial number in hash table for later reference.
|
-- serial number in hash table for later reference.
|
|
|
if Phase = Marking then
|
if Phase = Marking then
|
if S /= 0 then
|
if S /= 0 then
|
return; -- already visited
|
return; -- already visited
|
else
|
else
|
Set_Serial_Number;
|
Set_Serial_Number;
|
end if;
|
end if;
|
|
|
-- In printing phase, if already printed, then return, otherwise we
|
-- In printing phase, if already printed, then return, otherwise we
|
-- are printing the next item, so increment the serial number.
|
-- are printing the next item, so increment the serial number.
|
|
|
else
|
else
|
if S < Next_Serial_Number then
|
if S < Next_Serial_Number then
|
return; -- already printed
|
return; -- already printed
|
else
|
else
|
Next_Serial_Number := Next_Serial_Number + 1;
|
Next_Serial_Number := Next_Serial_Number + 1;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- Now process the list (Print calls have no effect in marking phase)
|
-- Now process the list (Print calls have no effect in marking phase)
|
|
|
Print_Str (Prefix_Str);
|
Print_Str (Prefix_Str);
|
Print_Elist_Ref (E);
|
Print_Elist_Ref (E);
|
Print_Eol;
|
Print_Eol;
|
|
|
if Is_Empty_Elmt_List (E) then
|
if Is_Empty_Elmt_List (E) then
|
Print_Str (Prefix_Str);
|
Print_Str (Prefix_Str);
|
Print_Str ("(Empty element list)");
|
Print_Str ("(Empty element list)");
|
Print_Eol;
|
Print_Eol;
|
Print_Eol;
|
Print_Eol;
|
|
|
else
|
else
|
if Phase = Printing then
|
if Phase = Printing then
|
M := First_Elmt (E);
|
M := First_Elmt (E);
|
while Present (M) loop
|
while Present (M) loop
|
N := Node (M);
|
N := Node (M);
|
Print_Str (Prefix_Str);
|
Print_Str (Prefix_Str);
|
Print_Str (" ");
|
Print_Str (" ");
|
Print_Node_Ref (N);
|
Print_Node_Ref (N);
|
Print_Eol;
|
Print_Eol;
|
Next_Elmt (M);
|
Next_Elmt (M);
|
end loop;
|
end loop;
|
|
|
Print_Str (Prefix_Str);
|
Print_Str (Prefix_Str);
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
M := First_Elmt (E);
|
M := First_Elmt (E);
|
while Present (M) loop
|
while Present (M) loop
|
Visit_Node (Node (M), Prefix_Str, ' ');
|
Visit_Node (Node (M), Prefix_Str, ' ');
|
Next_Elmt (M);
|
Next_Elmt (M);
|
end loop;
|
end loop;
|
end if;
|
end if;
|
end Visit_Elist;
|
end Visit_Elist;
|
|
|
----------------
|
----------------
|
-- Visit_List --
|
-- Visit_List --
|
----------------
|
----------------
|
|
|
procedure Visit_List (L : List_Id; Prefix_Str : String) is
|
procedure Visit_List (L : List_Id; Prefix_Str : String) is
|
N : Node_Id;
|
N : Node_Id;
|
S : constant Nat := Serial_Number (Int (L));
|
S : constant Nat := Serial_Number (Int (L));
|
|
|
begin
|
begin
|
-- In marking phase, return if already marked, otherwise set next
|
-- In marking phase, return if already marked, otherwise set next
|
-- serial number in hash table for later reference.
|
-- serial number in hash table for later reference.
|
|
|
if Phase = Marking then
|
if Phase = Marking then
|
if S /= 0 then
|
if S /= 0 then
|
return;
|
return;
|
else
|
else
|
Set_Serial_Number;
|
Set_Serial_Number;
|
end if;
|
end if;
|
|
|
-- In printing phase, if already printed, then return, otherwise we
|
-- In printing phase, if already printed, then return, otherwise we
|
-- are printing the next item, so increment the serial number.
|
-- are printing the next item, so increment the serial number.
|
|
|
else
|
else
|
if S < Next_Serial_Number then
|
if S < Next_Serial_Number then
|
return; -- already printed
|
return; -- already printed
|
else
|
else
|
Next_Serial_Number := Next_Serial_Number + 1;
|
Next_Serial_Number := Next_Serial_Number + 1;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- Now process the list (Print calls have no effect in marking phase)
|
-- Now process the list (Print calls have no effect in marking phase)
|
|
|
Print_Str (Prefix_Str);
|
Print_Str (Prefix_Str);
|
Print_List_Ref (L);
|
Print_List_Ref (L);
|
Print_Eol;
|
Print_Eol;
|
|
|
Print_Str (Prefix_Str);
|
Print_Str (Prefix_Str);
|
Print_Str ("|Parent = ");
|
Print_Str ("|Parent = ");
|
Print_Node_Ref (Parent (L));
|
Print_Node_Ref (Parent (L));
|
Print_Eol;
|
Print_Eol;
|
|
|
N := First (L);
|
N := First (L);
|
|
|
if N = Empty then
|
if N = Empty then
|
Print_Str (Prefix_Str);
|
Print_Str (Prefix_Str);
|
Print_Str ("(Empty list)");
|
Print_Str ("(Empty list)");
|
Print_Eol;
|
Print_Eol;
|
Print_Eol;
|
Print_Eol;
|
|
|
else
|
else
|
Print_Str (Prefix_Str);
|
Print_Str (Prefix_Str);
|
Print_Char ('|');
|
Print_Char ('|');
|
Print_Eol;
|
Print_Eol;
|
|
|
while Next (N) /= Empty loop
|
while Next (N) /= Empty loop
|
Visit_Node (N, Prefix_Str, '|');
|
Visit_Node (N, Prefix_Str, '|');
|
Next (N);
|
Next (N);
|
end loop;
|
end loop;
|
end if;
|
end if;
|
|
|
Visit_Node (N, Prefix_Str, ' ');
|
Visit_Node (N, Prefix_Str, ' ');
|
end Visit_List;
|
end Visit_List;
|
|
|
----------------
|
----------------
|
-- Visit_Node --
|
-- Visit_Node --
|
----------------
|
----------------
|
|
|
procedure Visit_Node
|
procedure Visit_Node
|
(N : Node_Id;
|
(N : Node_Id;
|
Prefix_Str : String;
|
Prefix_Str : String;
|
Prefix_Char : Character)
|
Prefix_Char : Character)
|
is
|
is
|
New_Prefix : String (Prefix_Str'First .. Prefix_Str'Last + 2);
|
New_Prefix : String (Prefix_Str'First .. Prefix_Str'Last + 2);
|
-- Prefix string for printing referenced fields
|
-- Prefix string for printing referenced fields
|
|
|
procedure Visit_Descendent
|
procedure Visit_Descendent
|
(D : Union_Id;
|
(D : Union_Id;
|
No_Indent : Boolean := False);
|
No_Indent : Boolean := False);
|
-- This procedure tests the given value of one of the Fields referenced
|
-- This procedure tests the given value of one of the Fields referenced
|
-- by the current node to determine whether to visit it recursively.
|
-- by the current node to determine whether to visit it recursively.
|
-- Normally No_Indent is false, which means that the visited node will
|
-- Normally No_Indent is false, which means that the visited node will
|
-- be indented using New_Prefix. If No_Indent is set to True, then
|
-- be indented using New_Prefix. If No_Indent is set to True, then
|
-- this indentation is skipped, and Prefix_Str is used for the call
|
-- this indentation is skipped, and Prefix_Str is used for the call
|
-- to print the descendent. No_Indent is effective only if the
|
-- to print the descendent. No_Indent is effective only if the
|
-- referenced descendent is a node.
|
-- referenced descendent is a node.
|
|
|
----------------------
|
----------------------
|
-- Visit_Descendent --
|
-- Visit_Descendent --
|
----------------------
|
----------------------
|
|
|
procedure Visit_Descendent
|
procedure Visit_Descendent
|
(D : Union_Id;
|
(D : Union_Id;
|
No_Indent : Boolean := False)
|
No_Indent : Boolean := False)
|
is
|
is
|
begin
|
begin
|
-- Case of descendent is a node
|
-- Case of descendent is a node
|
|
|
if D in Node_Range then
|
if D in Node_Range then
|
|
|
-- Don't bother about Empty or Error descendents
|
-- Don't bother about Empty or Error descendents
|
|
|
if D <= Union_Id (Empty_Or_Error) then
|
if D <= Union_Id (Empty_Or_Error) then
|
return;
|
return;
|
end if;
|
end if;
|
|
|
declare
|
declare
|
Nod : constant Node_Or_Entity_Id := Node_Or_Entity_Id (D);
|
Nod : constant Node_Or_Entity_Id := Node_Or_Entity_Id (D);
|
|
|
begin
|
begin
|
-- Descendents in one of the standardly compiled internal
|
-- Descendents in one of the standardly compiled internal
|
-- packages are normally ignored, unless the parent is also
|
-- packages are normally ignored, unless the parent is also
|
-- in such a package (happens when Standard itself is output)
|
-- in such a package (happens when Standard itself is output)
|
-- or if the -df switch is set which causes all links to be
|
-- or if the -df switch is set which causes all links to be
|
-- followed, even into package standard.
|
-- followed, even into package standard.
|
|
|
if Sloc (Nod) <= Standard_Location then
|
if Sloc (Nod) <= Standard_Location then
|
if Sloc (N) > Standard_Location
|
if Sloc (N) > Standard_Location
|
and then not Debug_Flag_F
|
and then not Debug_Flag_F
|
then
|
then
|
return;
|
return;
|
end if;
|
end if;
|
|
|
-- Don't bother about a descendent in a different unit than
|
-- Don't bother about a descendent in a different unit than
|
-- the node we came from unless the -df switch is set. Note
|
-- the node we came from unless the -df switch is set. Note
|
-- that we know at this point that Sloc (D) > Standard_Location
|
-- that we know at this point that Sloc (D) > Standard_Location
|
|
|
-- Note: the tests for No_Location here just make sure that we
|
-- Note: the tests for No_Location here just make sure that we
|
-- don't blow up on a node which is missing an Sloc value. This
|
-- don't blow up on a node which is missing an Sloc value. This
|
-- should not normally happen.
|
-- should not normally happen.
|
|
|
else
|
else
|
if (Sloc (N) <= Standard_Location
|
if (Sloc (N) <= Standard_Location
|
or else Sloc (N) = No_Location
|
or else Sloc (N) = No_Location
|
or else Sloc (Nod) = No_Location
|
or else Sloc (Nod) = No_Location
|
or else not In_Same_Source_Unit (Nod, N))
|
or else not In_Same_Source_Unit (Nod, N))
|
and then not Debug_Flag_F
|
and then not Debug_Flag_F
|
then
|
then
|
return;
|
return;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- Don't bother visiting a source node that has a parent which
|
-- Don't bother visiting a source node that has a parent which
|
-- is not the node we came from. We prefer to trace such nodes
|
-- is not the node we came from. We prefer to trace such nodes
|
-- from their real parents. This causes the tree to be printed
|
-- from their real parents. This causes the tree to be printed
|
-- in a more coherent order, e.g. a defining identifier listed
|
-- in a more coherent order, e.g. a defining identifier listed
|
-- next to its corresponding declaration, instead of next to
|
-- next to its corresponding declaration, instead of next to
|
-- some semantic reference.
|
-- some semantic reference.
|
|
|
-- This test is skipped for nodes in standard packages unless
|
-- This test is skipped for nodes in standard packages unless
|
-- the -dy option is set (which outputs the tree for standard)
|
-- the -dy option is set (which outputs the tree for standard)
|
|
|
-- Also, always follow pointers to Is_Itype entities,
|
-- Also, always follow pointers to Is_Itype entities,
|
-- since we want to list these when they are first referenced.
|
-- since we want to list these when they are first referenced.
|
|
|
if Parent (Nod) /= Empty
|
if Parent (Nod) /= Empty
|
and then Comes_From_Source (Nod)
|
and then Comes_From_Source (Nod)
|
and then Parent (Nod) /= N
|
and then Parent (Nod) /= N
|
and then (Sloc (N) > Standard_Location or else Debug_Flag_Y)
|
and then (Sloc (N) > Standard_Location or else Debug_Flag_Y)
|
then
|
then
|
return;
|
return;
|
end if;
|
end if;
|
|
|
-- If we successfully fall through all the above tests (which
|
-- If we successfully fall through all the above tests (which
|
-- execute a return if the node is not to be visited), we can
|
-- execute a return if the node is not to be visited), we can
|
-- go ahead and visit the node!
|
-- go ahead and visit the node!
|
|
|
if No_Indent then
|
if No_Indent then
|
Visit_Node (Nod, Prefix_Str, Prefix_Char);
|
Visit_Node (Nod, Prefix_Str, Prefix_Char);
|
else
|
else
|
Visit_Node (Nod, New_Prefix, ' ');
|
Visit_Node (Nod, New_Prefix, ' ');
|
end if;
|
end if;
|
end;
|
end;
|
|
|
-- Case of descendent is a list
|
-- Case of descendent is a list
|
|
|
elsif D in List_Range then
|
elsif D in List_Range then
|
|
|
-- Don't bother with a missing list, empty list or error list
|
-- Don't bother with a missing list, empty list or error list
|
|
|
if D = Union_Id (No_List)
|
if D = Union_Id (No_List)
|
or else D = Union_Id (Error_List)
|
or else D = Union_Id (Error_List)
|
or else Is_Empty_List (List_Id (D))
|
or else Is_Empty_List (List_Id (D))
|
then
|
then
|
return;
|
return;
|
|
|
-- Otherwise we can visit the list. Note that we don't bother
|
-- Otherwise we can visit the list. Note that we don't bother
|
-- to do the parent test that we did for the node case, because
|
-- to do the parent test that we did for the node case, because
|
-- it just does not happen that lists are referenced more than
|
-- it just does not happen that lists are referenced more than
|
-- one place in the tree. We aren't counting on this being the
|
-- one place in the tree. We aren't counting on this being the
|
-- case to generate valid output, it is just that we don't need
|
-- case to generate valid output, it is just that we don't need
|
-- in practice to worry about listing the list at a place that
|
-- in practice to worry about listing the list at a place that
|
-- is inconvenient.
|
-- is inconvenient.
|
|
|
else
|
else
|
Visit_List (List_Id (D), New_Prefix);
|
Visit_List (List_Id (D), New_Prefix);
|
end if;
|
end if;
|
|
|
-- Case of descendent is an element list
|
-- Case of descendent is an element list
|
|
|
elsif D in Elist_Range then
|
elsif D in Elist_Range then
|
|
|
-- Don't bother with a missing list, or an empty list
|
-- Don't bother with a missing list, or an empty list
|
|
|
if D = Union_Id (No_Elist)
|
if D = Union_Id (No_Elist)
|
or else Is_Empty_Elmt_List (Elist_Id (D))
|
or else Is_Empty_Elmt_List (Elist_Id (D))
|
then
|
then
|
return;
|
return;
|
|
|
-- Otherwise, visit the referenced element list
|
-- Otherwise, visit the referenced element list
|
|
|
else
|
else
|
Visit_Elist (Elist_Id (D), New_Prefix);
|
Visit_Elist (Elist_Id (D), New_Prefix);
|
end if;
|
end if;
|
|
|
-- For all other kinds of descendents (strings, names, uints etc),
|
-- For all other kinds of descendents (strings, names, uints etc),
|
-- there is nothing to visit (the contents of the field will be
|
-- there is nothing to visit (the contents of the field will be
|
-- printed when we print the containing node, but what concerns
|
-- printed when we print the containing node, but what concerns
|
-- us now is looking for descendents in the tree.
|
-- us now is looking for descendents in the tree.
|
|
|
else
|
else
|
null;
|
null;
|
end if;
|
end if;
|
end Visit_Descendent;
|
end Visit_Descendent;
|
|
|
-- Start of processing for Visit_Node
|
-- Start of processing for Visit_Node
|
|
|
begin
|
begin
|
if N = Empty then
|
if N = Empty then
|
return;
|
return;
|
end if;
|
end if;
|
|
|
-- Set fatal error node in case we get a blow up during the trace
|
-- Set fatal error node in case we get a blow up during the trace
|
|
|
Current_Error_Node := N;
|
Current_Error_Node := N;
|
|
|
New_Prefix (Prefix_Str'Range) := Prefix_Str;
|
New_Prefix (Prefix_Str'Range) := Prefix_Str;
|
New_Prefix (Prefix_Str'Last + 1) := Prefix_Char;
|
New_Prefix (Prefix_Str'Last + 1) := Prefix_Char;
|
New_Prefix (Prefix_Str'Last + 2) := ' ';
|
New_Prefix (Prefix_Str'Last + 2) := ' ';
|
|
|
-- In the marking phase, all we do is to set the serial number
|
-- In the marking phase, all we do is to set the serial number
|
|
|
if Phase = Marking then
|
if Phase = Marking then
|
if Serial_Number (Int (N)) /= 0 then
|
if Serial_Number (Int (N)) /= 0 then
|
return; -- already visited
|
return; -- already visited
|
else
|
else
|
Set_Serial_Number;
|
Set_Serial_Number;
|
end if;
|
end if;
|
|
|
-- In the printing phase, we print the node
|
-- In the printing phase, we print the node
|
|
|
else
|
else
|
if Serial_Number (Int (N)) < Next_Serial_Number then
|
if Serial_Number (Int (N)) < Next_Serial_Number then
|
|
|
-- Here we have already visited the node, but if it is in
|
-- Here we have already visited the node, but if it is in
|
-- a list, we still want to print the reference, so that
|
-- a list, we still want to print the reference, so that
|
-- it is clear that it belongs to the list.
|
-- it is clear that it belongs to the list.
|
|
|
if Is_List_Member (N) then
|
if Is_List_Member (N) then
|
Print_Str (Prefix_Str);
|
Print_Str (Prefix_Str);
|
Print_Node_Ref (N);
|
Print_Node_Ref (N);
|
Print_Eol;
|
Print_Eol;
|
Print_Str (Prefix_Str);
|
Print_Str (Prefix_Str);
|
Print_Char (Prefix_Char);
|
Print_Char (Prefix_Char);
|
Print_Str ("(already output)");
|
Print_Str ("(already output)");
|
Print_Eol;
|
Print_Eol;
|
Print_Str (Prefix_Str);
|
Print_Str (Prefix_Str);
|
Print_Char (Prefix_Char);
|
Print_Char (Prefix_Char);
|
Print_Eol;
|
Print_Eol;
|
end if;
|
end if;
|
|
|
return;
|
return;
|
|
|
else
|
else
|
Print_Node (N, Prefix_Str, Prefix_Char);
|
Print_Node (N, Prefix_Str, Prefix_Char);
|
Print_Str (Prefix_Str);
|
Print_Str (Prefix_Str);
|
Print_Char (Prefix_Char);
|
Print_Char (Prefix_Char);
|
Print_Eol;
|
Print_Eol;
|
Next_Serial_Number := Next_Serial_Number + 1;
|
Next_Serial_Number := Next_Serial_Number + 1;
|
end if;
|
end if;
|
end if;
|
end if;
|
|
|
-- Visit all descendents of this node
|
-- Visit all descendents of this node
|
|
|
if Nkind (N) not in N_Entity then
|
if Nkind (N) not in N_Entity then
|
Visit_Descendent (Field1 (N));
|
Visit_Descendent (Field1 (N));
|
Visit_Descendent (Field2 (N));
|
Visit_Descendent (Field2 (N));
|
Visit_Descendent (Field3 (N));
|
Visit_Descendent (Field3 (N));
|
Visit_Descendent (Field4 (N));
|
Visit_Descendent (Field4 (N));
|
Visit_Descendent (Field5 (N));
|
Visit_Descendent (Field5 (N));
|
|
|
-- Entity case
|
-- Entity case
|
|
|
else
|
else
|
Visit_Descendent (Field1 (N));
|
Visit_Descendent (Field1 (N));
|
Visit_Descendent (Field3 (N));
|
Visit_Descendent (Field3 (N));
|
Visit_Descendent (Field4 (N));
|
Visit_Descendent (Field4 (N));
|
Visit_Descendent (Field5 (N));
|
Visit_Descendent (Field5 (N));
|
Visit_Descendent (Field6 (N));
|
Visit_Descendent (Field6 (N));
|
Visit_Descendent (Field7 (N));
|
Visit_Descendent (Field7 (N));
|
Visit_Descendent (Field8 (N));
|
Visit_Descendent (Field8 (N));
|
Visit_Descendent (Field9 (N));
|
Visit_Descendent (Field9 (N));
|
Visit_Descendent (Field10 (N));
|
Visit_Descendent (Field10 (N));
|
Visit_Descendent (Field11 (N));
|
Visit_Descendent (Field11 (N));
|
Visit_Descendent (Field12 (N));
|
Visit_Descendent (Field12 (N));
|
Visit_Descendent (Field13 (N));
|
Visit_Descendent (Field13 (N));
|
Visit_Descendent (Field14 (N));
|
Visit_Descendent (Field14 (N));
|
Visit_Descendent (Field15 (N));
|
Visit_Descendent (Field15 (N));
|
Visit_Descendent (Field16 (N));
|
Visit_Descendent (Field16 (N));
|
Visit_Descendent (Field17 (N));
|
Visit_Descendent (Field17 (N));
|
Visit_Descendent (Field18 (N));
|
Visit_Descendent (Field18 (N));
|
Visit_Descendent (Field19 (N));
|
Visit_Descendent (Field19 (N));
|
Visit_Descendent (Field20 (N));
|
Visit_Descendent (Field20 (N));
|
Visit_Descendent (Field21 (N));
|
Visit_Descendent (Field21 (N));
|
Visit_Descendent (Field22 (N));
|
Visit_Descendent (Field22 (N));
|
Visit_Descendent (Field23 (N));
|
Visit_Descendent (Field23 (N));
|
|
|
-- Now an interesting kludge. Normally parents are always printed
|
-- Now an interesting kludge. Normally parents are always printed
|
-- since we traverse the tree in a downwards direction. There is
|
-- since we traverse the tree in a downwards direction. There is
|
-- however an exception to this rule, which is the case where a
|
-- however an exception to this rule, which is the case where a
|
-- parent is constructed by the compiler and is not referenced
|
-- parent is constructed by the compiler and is not referenced
|
-- elsewhere in the tree. The following catches this case
|
-- elsewhere in the tree. The following catches this case
|
|
|
if not Comes_From_Source (N) then
|
if not Comes_From_Source (N) then
|
Visit_Descendent (Union_Id (Parent (N)));
|
Visit_Descendent (Union_Id (Parent (N)));
|
end if;
|
end if;
|
|
|
-- You may be wondering why we omitted Field2 above. The answer
|
-- You may be wondering why we omitted Field2 above. The answer
|
-- is that this is the Next_Entity field, and we want to treat
|
-- is that this is the Next_Entity field, and we want to treat
|
-- it rather specially. Why? Because a Next_Entity link does not
|
-- it rather specially. Why? Because a Next_Entity link does not
|
-- correspond to a level deeper in the tree, and we do not want
|
-- correspond to a level deeper in the tree, and we do not want
|
-- the tree to march off to the right of the page due to bogus
|
-- the tree to march off to the right of the page due to bogus
|
-- indentations coming from this effect.
|
-- indentations coming from this effect.
|
|
|
-- To prevent this, what we do is to control references via
|
-- To prevent this, what we do is to control references via
|
-- Next_Entity only from the first entity on a given scope
|
-- Next_Entity only from the first entity on a given scope
|
-- chain, and we keep them all at the same level. Of course
|
-- chain, and we keep them all at the same level. Of course
|
-- if an entity has already been referenced it is not printed.
|
-- if an entity has already been referenced it is not printed.
|
|
|
if Present (Next_Entity (N))
|
if Present (Next_Entity (N))
|
and then Present (Scope (N))
|
and then Present (Scope (N))
|
and then First_Entity (Scope (N)) = N
|
and then First_Entity (Scope (N)) = N
|
then
|
then
|
declare
|
declare
|
Nod : Node_Id;
|
Nod : Node_Id;
|
|
|
begin
|
begin
|
Nod := N;
|
Nod := N;
|
while Present (Nod) loop
|
while Present (Nod) loop
|
Visit_Descendent (Union_Id (Next_Entity (Nod)));
|
Visit_Descendent (Union_Id (Next_Entity (Nod)));
|
Nod := Next_Entity (Nod);
|
Nod := Next_Entity (Nod);
|
end loop;
|
end loop;
|
end;
|
end;
|
end if;
|
end if;
|
end if;
|
end if;
|
end Visit_Node;
|
end Visit_Node;
|
|
|
end Treepr;
|
end Treepr;
|
|
|