with Atree; use Atree;
with Csets; use Csets;
with Debug; use Debug;
with Einfo; use Einfo;
with Elists; use Elists;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Output; use Output;
with Sem_Mech; use Sem_Mech;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Sinput; use Sinput;
with Stand; use Stand;
with Stringt; use Stringt;
with Treeprs; use Treeprs;
with Uintp; use Uintp;
with Urealp; use Urealp;
with Uname; use Uname;
with Unchecked_Deallocation;
package body Treepr is
use Atree.Unchecked_Access;
type Hash_Record is record
Serial : Nat;
Id : Int;
end record;
type Hash_Table_Type is array (Nat range <>) of Hash_Record;
type Access_Hash_Table_Type is access Hash_Table_Type;
Hash_Table : Access_Hash_Table_Type;
Hash_Table_Len : Nat;
Next_Serial_Number : Nat;
Printing_Descendants : Boolean;
type Phase_Type is (Marking, Printing);
Phase : Phase_Type;
procedure Print_End_Span (N : Node_Id);
procedure Print_Init;
procedure Print_Term;
procedure Print_Char (C : Character);
procedure Print_Name (N : Name_Id);
procedure Print_Node_Kind (N : Node_Id);
procedure Print_Str (S : String);
procedure Print_Str_Mixed_Case (S : String);
procedure Print_Int (I : Int);
procedure Print_Eol;
procedure Print_Node_Ref (N : Node_Id);
procedure Print_List_Ref (L : List_Id);
procedure Print_Elist_Ref (E : Elist_Id);
procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String);
procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto);
procedure Print_Flag (F : Boolean);
procedure Print_Node
(N : Node_Id;
Prefix_Str : String;
Prefix_Char : Character);
function Serial_Number (Id : Int) return Nat;
procedure Set_Serial_Number;
procedure Visit_Node
(N : Node_Id;
Prefix_Str : String;
Prefix_Char : Character);
procedure Visit_List (L : List_Id; Prefix_Str : String);
procedure Visit_Elist (E : Elist_Id; Prefix_Str : String);
procedure pe (E : Elist_Id) is
begin
Print_Tree_Elist (E);
end pe;
procedure pl (L : List_Id) is
begin
Print_Tree_List (L);
end pl;
procedure pn (N : Node_Id) is
begin
Print_Tree_Node (N);
end pn;
procedure Print_Char (C : Character) is
begin
if Phase = Printing then
Write_Char (C);
end if;
end Print_Char;
procedure Print_Elist_Ref (E : Elist_Id) is
begin
if Phase /= Printing then
return;
end if;
if E = No_Elist then
Write_Str ("<no elist>");
elsif Is_Empty_Elmt_List (E) then
Write_Str ("Empty elist, (Elist_Id=");
Write_Int (Int (E));
Write_Char (')');
else
Write_Str ("(Elist_Id=");
Write_Int (Int (E));
Write_Char (')');
if Printing_Descendants then
Write_Str (" #");
Write_Int (Serial_Number (Int (E)));
end if;
end if;
end Print_Elist_Ref;
procedure Print_Elist_Subtree (E : Elist_Id) is
begin
Print_Init;
Next_Serial_Number := 1;
Phase := Marking;
Visit_Elist (E, "");
Next_Serial_Number := 1;
Phase := Printing;
Visit_Elist (E, "");
Print_Term;
end Print_Elist_Subtree;
procedure Print_End_Span (N : Node_Id) is
Val : constant Uint := End_Span (N);
begin
UI_Write (Val);
Write_Str (" (Uint = ");
Write_Int (Int (Field5 (N)));
Write_Str (") ");
if Val /= No_Uint then
Write_Location (End_Location (N));
end if;
end Print_End_Span;
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 is
begin
return
U /= Union_Id (Empty) and then
U /= To_Union (No_Uint) and then
U /= To_Union (No_Ureal) and then
U /= Union_Id (No_String);
end Field_Present;
begin
Print_Str (Prefix);
Print_Str ("Ekind = ");
Print_Str_Mixed_Case (Entity_Kind'Image (Ekind (Ent)));
Print_Eol;
Print_Str (Prefix);
Print_Str ("Etype = ");
Print_Node_Ref (Etype (Ent));
Print_Eol;
if Convention (Ent) /= Convention_Ada then
Print_Str (Prefix);
Print_Str ("Convention = ");
declare
S : constant String := Convention_Id'Image (Convention (Ent));
begin
Print_Str_Mixed_Case (S (12 .. S'Last));
Print_Eol;
end;
end if;
if Field_Present (Field6 (Ent)) then
Print_Str (Prefix);
Write_Field6_Name (Ent);
Write_Str (" = ");
Print_Field (Field6 (Ent));
Print_Eol;
end if;
if Field_Present (Field7 (Ent)) then
Print_Str (Prefix);
Write_Field7_Name (Ent);
Write_Str (" = ");
Print_Field (Field7 (Ent));
Print_Eol;
end if;
if Field_Present (Field8 (Ent)) then
Print_Str (Prefix);
Write_Field8_Name (Ent);
Write_Str (" = ");
Print_Field (Field8 (Ent));
Print_Eol;
end if;
if Field_Present (Field9 (Ent)) then
Print_Str (Prefix);
Write_Field9_Name (Ent);
Write_Str (" = ");
Print_Field (Field9 (Ent));
Print_Eol;
end if;
if Field_Present (Field10 (Ent)) then
Print_Str (Prefix);
Write_Field10_Name (Ent);
Write_Str (" = ");
Print_Field (Field10 (Ent));
Print_Eol;
end if;
if Field_Present (Field11 (Ent)) then
Print_Str (Prefix);
Write_Field11_Name (Ent);
Write_Str (" = ");
Print_Field (Field11 (Ent));
Print_Eol;
end if;
if Field_Present (Field12 (Ent)) then
Print_Str (Prefix);
Write_Field12_Name (Ent);
Write_Str (" = ");
Print_Field (Field12 (Ent));
Print_Eol;
end if;
if Field_Present (Field13 (Ent)) then
Print_Str (Prefix);
Write_Field13_Name (Ent);
Write_Str (" = ");
Print_Field (Field13 (Ent));
Print_Eol;
end if;
if Field_Present (Field14 (Ent)) then
Print_Str (Prefix);
Write_Field14_Name (Ent);
Write_Str (" = ");
Print_Field (Field14 (Ent));
Print_Eol;
end if;
if Field_Present (Field15 (Ent)) then
Print_Str (Prefix);
Write_Field15_Name (Ent);
Write_Str (" = ");
Print_Field (Field15 (Ent));
Print_Eol;
end if;
if Field_Present (Field16 (Ent)) then
Print_Str (Prefix);
Write_Field16_Name (Ent);
Write_Str (" = ");
Print_Field (Field16 (Ent));
Print_Eol;
end if;
if Field_Present (Field17 (Ent)) then
Print_Str (Prefix);
Write_Field17_Name (Ent);
Write_Str (" = ");
Print_Field (Field17 (Ent));
Print_Eol;
end if;
if Field_Present (Field18 (Ent)) then
Print_Str (Prefix);
Write_Field18_Name (Ent);
Write_Str (" = ");
Print_Field (Field18 (Ent));
Print_Eol;
end if;
if Field_Present (Field19 (Ent)) then
Print_Str (Prefix);
Write_Field19_Name (Ent);
Write_Str (" = ");
Print_Field (Field19 (Ent));
Print_Eol;
end if;
if Field_Present (Field20 (Ent)) then
Print_Str (Prefix);
Write_Field20_Name (Ent);
Write_Str (" = ");
Print_Field (Field20 (Ent));
Print_Eol;
end if;
if Field_Present (Field21 (Ent)) then
Print_Str (Prefix);
Write_Field21_Name (Ent);
Write_Str (" = ");
Print_Field (Field21 (Ent));
Print_Eol;
end if;
if Field_Present (Field22 (Ent)) then
Print_Str (Prefix);
Write_Field22_Name (Ent);
Write_Str (" = ");
if Ekind (Ent) = E_Function or else Is_Formal (Ent) then
declare
M : constant Mechanism_Type := Mechanism (Ent);
begin
case M is
when Default_Mechanism => Write_Str ("Default");
when By_Copy => Write_Str ("By_Copy");
when By_Reference => Write_Str ("By_Reference");
when By_Descriptor => Write_Str ("By_Descriptor");
when By_Descriptor_UBS => Write_Str ("By_Descriptor_UBS");
when By_Descriptor_UBSB => Write_Str ("By_Descriptor_UBSB");
when By_Descriptor_UBA => Write_Str ("By_Descriptor_UBA");
when By_Descriptor_S => Write_Str ("By_Descriptor_S");
when By_Descriptor_SB => Write_Str ("By_Descriptor_SB");
when By_Descriptor_A => Write_Str ("By_Descriptor_A");
when By_Descriptor_NCA => Write_Str ("By_Descriptor_NCA");
when 1 .. Mechanism_Type'Last =>
Write_Str ("By_Copy if size <= ");
Write_Int (Int (M));
end case;
end;
else
Print_Field (Field22 (Ent));
end if;
Print_Eol;
end if;
if Field_Present (Field23 (Ent)) then
Print_Str (Prefix);
Write_Field23_Name (Ent);
Write_Str (" = ");
Print_Field (Field23 (Ent));
Print_Eol;
end if;
if Field_Present (Field24 (Ent)) then
Print_Str (Prefix);
Write_Field24_Name (Ent);
Write_Str (" = ");
Print_Field (Field24 (Ent));
Print_Eol;
end if;
if Field_Present (Field25 (Ent)) then
Print_Str (Prefix);
Write_Field25_Name (Ent);
Write_Str (" = ");
Print_Field (Field25 (Ent));
Print_Eol;
end if;
if Field_Present (Field26 (Ent)) then
Print_Str (Prefix);
Write_Field26_Name (Ent);
Write_Str (" = ");
Print_Field (Field26 (Ent));
Print_Eol;
end if;
if Field_Present (Field27 (Ent)) then
Print_Str (Prefix);
Write_Field27_Name (Ent);
Write_Str (" = ");
Print_Field (Field27 (Ent));
Print_Eol;
end if;
Write_Entity_Flags (Ent, Prefix);
end Print_Entity_Info;
procedure Print_Eol is
begin
if Phase = Printing then
Write_Eol;
end if;
end Print_Eol;
procedure Print_Field (Val : Union_Id; Format : UI_Format := Auto) is
begin
if Phase /= Printing then
return;
end if;
if Val in Node_Range then
Print_Node_Ref (Node_Id (Val));
elsif Val in List_Range then
Print_List_Ref (List_Id (Val));
elsif Val in Elist_Range then
Print_Elist_Ref (Elist_Id (Val));
elsif Val in Names_Range then
Print_Name (Name_Id (Val));
Write_Str (" (Name_Id=");
Write_Int (Int (Val));
Write_Char (')');
elsif Val in Strings_Range then
Write_String_Table_Entry (String_Id (Val));
Write_Str (" (String_Id=");
Write_Int (Int (Val));
Write_Char (')');
elsif Val in Uint_Range then
UI_Write (From_Union (Val), Format);
Write_Str (" (Uint = ");
Write_Int (Int (Val));
Write_Char (')');
elsif Val in Ureal_Range then
UR_Write (From_Union (Val));
Write_Str (" (Ureal = ");
Write_Int (Int (Val));
Write_Char (')');
else
Print_Str ("****** Incorrect value = ");
Print_Int (Int (Val));
end if;
end Print_Field;
procedure Print_Flag (F : Boolean) is
begin
if F then
Print_Str ("True");
else
Print_Str ("False");
end if;
end Print_Flag;
procedure Print_Init is
begin
Printing_Descendants := True;
Write_Eol;
Hash_Table_Len := (150 * (Num_Nodes + Num_Lists + Num_Elists)) / 100;
Hash_Table := new Hash_Table_Type (0 .. Hash_Table_Len - 1);
for J in Hash_Table'Range loop
Hash_Table (J).Serial := 0;
end loop;
end Print_Init;
procedure Print_Int (I : Int) is
begin
if Phase = Printing then
Write_Int (I);
end if;
end Print_Int;
procedure Print_List_Ref (L : List_Id) is
begin
if Phase /= Printing then
return;
end if;
if No (L) then
Write_Str ("<no list>");
elsif Is_Empty_List (L) then
Write_Str ("<empty list> (List_Id=");
Write_Int (Int (L));
Write_Char (')');
else
Write_Str ("List");
if Printing_Descendants then
Write_Str (" #");
Write_Int (Serial_Number (Int (L)));
end if;
Write_Str (" (List_Id=");
Write_Int (Int (L));
Write_Char (')');
end if;
end Print_List_Ref;
procedure Print_List_Subtree (L : List_Id) is
begin
Print_Init;
Next_Serial_Number := 1;
Phase := Marking;
Visit_List (L, "");
Next_Serial_Number := 1;
Phase := Printing;
Visit_List (L, "");
Print_Term;
end Print_List_Subtree;
procedure Print_Name (N : Name_Id) is
begin
if Phase = Printing then
if N = No_Name then
Print_Str ("<No_Name>");
elsif N = Error_Name then
Print_Str ("<Error_Name>");
else
Get_Name_String (N);
Print_Char ('"');
Write_Name (N);
Print_Char ('"');
end if;
end if;
end Print_Name;
procedure Print_Node
(N : Node_Id;
Prefix_Str : String;
Prefix_Char : Character)
is
F : Fchar;
P : Natural := Pchar_Pos (Nkind (N));
Field_To_Be_Printed : Boolean;
Prefix_Str_Char : String (Prefix_Str'First .. Prefix_Str'Last + 1);
Sfile : Source_File_Index;
Notes : Boolean;
Fmt : UI_Format;
begin
if Phase /= Printing then
return;
end if;
if Nkind (N) = N_Integer_Literal and then Print_In_Hex (N) then
Fmt := Hex;
else
Fmt := Auto;
end if;
Prefix_Str_Char (Prefix_Str'Range) := Prefix_Str;
Prefix_Str_Char (Prefix_Str'Last + 1) := Prefix_Char;
Print_Str (Prefix_Str);
Print_Node_Ref (N);
Notes := False;
if Comes_From_Source (N) then
Notes := True;
Print_Str (" (source");
end if;
if Analyzed (N) then
if not Notes then
Notes := True;
Print_Str (" (");
else
Print_Str (",");
end if;
Print_Str ("analyzed");
end if;
if Error_Posted (N) then
if not Notes then
Notes := True;
Print_Str (" (");
else
Print_Str (",");
end if;
Print_Str ("posted");
end if;
if Notes then
Print_Char (')');
end if;
Print_Eol;
if Is_Rewrite_Substitution (N) then
Print_Str (Prefix_Str);
Print_Str (" Rewritten: original node = ");
Print_Node_Ref (Original_Node (N));
Print_Eol;
end if;
if N = Empty then
return;
end if;
if not Is_List_Member (N) then
Print_Str (Prefix_Str);
Print_Str (" Parent = ");
Print_Node_Ref (Parent (N));
Print_Eol;
end if;
if Sloc (N) /= No_Location then
Print_Str (Prefix_Str_Char);
Print_Str ("Sloc = ");
if Sloc (N) = Standard_Location then
Print_Str ("Standard_Location");
elsif Sloc (N) = Standard_ASCII_Location then
Print_Str ("Standard_ASCII_Location");
else
Sfile := Get_Source_File_Index (Sloc (N));
Print_Int (Int (Sloc (N)) - Int (Source_Text (Sfile)'First));
Write_Str (" ");
Write_Location (Sloc (N));
end if;
Print_Eol;
end if;
if Nkind (N) in N_Has_Chars and then Chars (N) /= No_Name then
Print_Str (Prefix_Str_Char);
Print_Str ("Chars = ");
Print_Name (Chars (N));
Write_Str (" (Name_Id=");
Write_Int (Int (Chars (N)));
Write_Char (')');
Print_Eol;
end if;
if Nkind (N) not in N_Entity then
if Nkind (N) in N_Op
or else Nkind (N) = N_And_Then
or else Nkind (N) = N_In
or else Nkind (N) = N_Not_In
or else Nkind (N) = N_Or_Else
then
if Nkind (N) not in N_Unary_Op then
Print_Str (Prefix_Str_Char);
Print_Str ("Left_Opnd = ");
Print_Node_Ref (Left_Opnd (N));
Print_Eol;
end if;
Print_Str (Prefix_Str_Char);
Print_Str ("Right_Opnd = ");
Print_Node_Ref (Right_Opnd (N));
Print_Eol;
end if;
if Nkind (N) in N_Op and then Present (Entity (N)) then
Print_Str (Prefix_Str_Char);
Print_Str ("Entity = ");
Print_Node_Ref (Entity (N));
Print_Eol;
end if;
if Nkind (N) in N_Subexpr then
if Assignment_OK (N) then
Print_Str (Prefix_Str_Char);
Print_Str ("Assignment_OK = True");
Print_Eol;
end if;
if Do_Range_Check (N) then
Print_Str (Prefix_Str_Char);
Print_Str ("Do_Range_Check = True");
Print_Eol;
end if;
if Has_Dynamic_Length_Check (N) then
Print_Str (Prefix_Str_Char);
Print_Str ("Has_Dynamic_Length_Check = True");
Print_Eol;
end if;
if Has_Dynamic_Range_Check (N) then
Print_Str (Prefix_Str_Char);
Print_Str ("Has_Dynamic_Range_Check = True");
Print_Eol;
end if;
if Is_Controlling_Actual (N) then
Print_Str (Prefix_Str_Char);
Print_Str ("Is_Controlling_Actual = True");
Print_Eol;
end if;
if Is_Overloaded (N) then
Print_Str (Prefix_Str_Char);
Print_Str ("Is_Overloaded = True");
Print_Eol;
end if;
if Is_Static_Expression (N) then
Print_Str (Prefix_Str_Char);
Print_Str ("Is_Static_Expression = True");
Print_Eol;
end if;
if Must_Not_Freeze (N) then
Print_Str (Prefix_Str_Char);
Print_Str ("Must_Not_Freeze = True");
Print_Eol;
end if;
if Paren_Count (N) /= 0 then
Print_Str (Prefix_Str_Char);
Print_Str ("Paren_Count = ");
Print_Int (Int (Paren_Count (N)));
Print_Eol;
end if;
if Raises_Constraint_Error (N) then
Print_Str (Prefix_Str_Char);
Print_Str ("Raise_Constraint_Error = True");
Print_Eol;
end if;
end if;
if Nkind (N) in N_Op and then Do_Overflow_Check (N) then
Print_Str (Prefix_Str_Char);
Print_Str ("Do_Overflow_Check = True");
Print_Eol;
end if;
if Nkind (N) in N_Has_Etype
and then Present (Etype (N))
then
Print_Str (Prefix_Str_Char);
Print_Str ("Etype = ");
Print_Node_Ref (Etype (N));
Print_Eol;
end if;
end if;
while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) loop
F := Pchars (P);
P := P + 1;
case F is
when F_Field1 =>
Field_To_Be_Printed := Field1 (N) /= Union_Id (Empty);
when F_Field2 =>
Field_To_Be_Printed := Field2 (N) /= Union_Id (Empty);
when F_Field3 =>
Field_To_Be_Printed := Field3 (N) /= Union_Id (Empty);
when F_Field4 =>
Field_To_Be_Printed := Field4 (N) /= Union_Id (Empty);
when F_Field5 =>
Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty);
when F_Flag4 => Field_To_Be_Printed := Flag4 (N);
when F_Flag5 => Field_To_Be_Printed := Flag5 (N);
when F_Flag6 => Field_To_Be_Printed := Flag6 (N);
when F_Flag7 => Field_To_Be_Printed := Flag7 (N);
when F_Flag8 => Field_To_Be_Printed := Flag8 (N);
when F_Flag9 => Field_To_Be_Printed := Flag9 (N);
when F_Flag10 => Field_To_Be_Printed := Flag10 (N);
when F_Flag11 => Field_To_Be_Printed := Flag11 (N);
when F_Flag12 => Field_To_Be_Printed := Flag12 (N);
when F_Flag13 => Field_To_Be_Printed := Flag13 (N);
when F_Flag14 => Field_To_Be_Printed := Flag14 (N);
when F_Flag15 => Field_To_Be_Printed := Flag15 (N);
when F_Flag16 => Field_To_Be_Printed := Flag16 (N);
when F_Flag17 => Field_To_Be_Printed := Flag17 (N);
when F_Flag18 => Field_To_Be_Printed := Flag18 (N);
when F_Flag1 => raise Program_Error;
when F_Flag2 => raise Program_Error;
when F_Flag3 => raise Program_Error;
end case;
if Field_To_Be_Printed then
Print_Str (Prefix_Str_Char);
while P < Pchar_Pos (Node_Kind'Succ (Nkind (N)))
and then Pchars (P) not in Fchar
loop
Print_Char (Pchars (P));
P := P + 1;
end loop;
Print_Str (" = ");
case F is
when F_Field1 => Print_Field (Field1 (N), Fmt);
when F_Field2 => Print_Field (Field2 (N), Fmt);
when F_Field3 => Print_Field (Field3 (N), Fmt);
when F_Field4 => Print_Field (Field4 (N), Fmt);
when F_Field5 =>
if Nkind (N) = N_Case_Statement
or else Nkind (N) = N_If_Statement
then
Print_End_Span (N);
else
Print_Field (Field5 (N), Fmt);
end if;
when F_Flag4 => Print_Flag (Flag4 (N));
when F_Flag5 => Print_Flag (Flag5 (N));
when F_Flag6 => Print_Flag (Flag6 (N));
when F_Flag7 => Print_Flag (Flag7 (N));
when F_Flag8 => Print_Flag (Flag8 (N));
when F_Flag9 => Print_Flag (Flag9 (N));
when F_Flag10 => Print_Flag (Flag10 (N));
when F_Flag11 => Print_Flag (Flag11 (N));
when F_Flag12 => Print_Flag (Flag12 (N));
when F_Flag13 => Print_Flag (Flag13 (N));
when F_Flag14 => Print_Flag (Flag14 (N));
when F_Flag15 => Print_Flag (Flag15 (N));
when F_Flag16 => Print_Flag (Flag16 (N));
when F_Flag17 => Print_Flag (Flag17 (N));
when F_Flag18 => Print_Flag (Flag18 (N));
when F_Flag1 => raise Program_Error;
when F_Flag2 => raise Program_Error;
when F_Flag3 => raise Program_Error;
end case;
Print_Eol;
else
while P < Pchar_Pos (Node_Kind'Succ (Nkind (N)))
and then Pchars (P) not in Fchar
loop
P := P + 1;
end loop;
end if;
end loop;
if Nkind (N) in N_Entity then
Print_Entity_Info (N, Prefix_Str_Char);
end if;
end Print_Node;
procedure Print_Node_Kind (N : Node_Id) is
Ucase : Boolean;
S : constant String := Node_Kind'Image (Nkind (N));
begin
if Phase = Printing then
Ucase := True;
for J in S'Range loop
if Ucase then
Write_Char (Fold_Upper (S (J)));
else
Write_Char (Fold_Lower (S (J)));
end if;
Ucase := (S (J) = '_');
end loop;
end if;
end Print_Node_Kind;
procedure Print_Node_Ref (N : Node_Id) is
S : Nat;
begin
if Phase /= Printing then
return;
end if;
if N = Empty then
Write_Str ("<empty>");
elsif N = Error then
Write_Str ("<error>");
else
if Printing_Descendants then
S := Serial_Number (Int (N));
if S /= 0 then
Write_Str ("Node");
Write_Str (" #");
Write_Int (S);
Write_Char (' ');
end if;
end if;
Print_Node_Kind (N);
if Nkind (N) in N_Has_Chars then
Write_Char (' ');
Print_Name (Chars (N));
end if;
if Nkind (N) in N_Entity then
Write_Str (" (Entity_Id=");
else
Write_Str (" (Node_Id=");
end if;
Write_Int (Int (N));
if Sloc (N) <= Standard_Location then
Write_Char ('s');
end if;
Write_Char (')');
end if;
end Print_Node_Ref;
procedure Print_Node_Subtree (N : Node_Id) is
begin
Print_Init;
Next_Serial_Number := 1;
Phase := Marking;
Visit_Node (N, "", ' ');
Next_Serial_Number := 1;
Phase := Printing;
Visit_Node (N, "", ' ');
Print_Term;
end Print_Node_Subtree;
procedure Print_Str (S : String) is
begin
if Phase = Printing then
Write_Str (S);
end if;
end Print_Str;
procedure Print_Str_Mixed_Case (S : String) is
Ucase : Boolean;
begin
if Phase = Printing then
Ucase := True;
for J in S'Range loop
if Ucase then
Write_Char (S (J));
else
Write_Char (Fold_Lower (S (J)));
end if;
Ucase := (S (J) = '_');
end loop;
end if;
end Print_Str_Mixed_Case;
procedure Print_Term is
procedure Free is new Unchecked_Deallocation
(Hash_Table_Type, Access_Hash_Table_Type);
begin
Free (Hash_Table);
end Print_Term;
procedure Print_Tree_Elist (E : Elist_Id) is
M : Elmt_Id;
begin
Printing_Descendants := False;
Phase := Printing;
Print_Elist_Ref (E);
Print_Eol;
M := First_Elmt (E);
if No (M) then
Print_Str ("<empty element list>");
Print_Eol;
else
loop
Print_Char ('|');
Print_Eol;
exit when No (Next_Elmt (M));
Print_Node (Node (M), "", '|');
Next_Elmt (M);
end loop;
Print_Node (Node (M), "", ' ');
Print_Eol;
end if;
end Print_Tree_Elist;
procedure Print_Tree_List (L : List_Id) is
N : Node_Id;
begin
Printing_Descendants := False;
Phase := Printing;
Print_List_Ref (L);
Print_Str (" List_Id=");
Print_Int (Int (L));
Print_Eol;
N := First (L);
if N = Empty then
Print_Str ("<empty node list>");
Print_Eol;
else
loop
Print_Char ('|');
Print_Eol;
exit when Next (N) = Empty;
Print_Node (N, "", '|');
Next (N);
end loop;
Print_Node (N, "", ' ');
Print_Eol;
end if;
end Print_Tree_List;
procedure Print_Tree_Node (N : Node_Id; Label : String := "") is
begin
Printing_Descendants := False;
Phase := Printing;
Print_Node (N, Label, ' ');
end Print_Tree_Node;
procedure pt (N : Node_Id) is
begin
Print_Node_Subtree (N);
end pt;
Hash_Slot : Nat;
function Serial_Number (Id : Int) return Nat is
H : Int := Id mod Hash_Table_Len;
begin
while Hash_Table (H).Serial /= 0 loop
if Id = Hash_Table (H).Id then
return Hash_Table (H).Serial;
end if;
H := H + 1;
if H > Hash_Table'Last then
H := 0;
end if;
end loop;
Hash_Slot := H;
Hash_Table (H).Id := Id;
return 0;
end Serial_Number;
procedure Set_Serial_Number is
begin
Hash_Table (Hash_Slot).Serial := Next_Serial_Number;
Next_Serial_Number := Next_Serial_Number + 1;
end Set_Serial_Number;
procedure Tree_Dump is
procedure Underline;
procedure Underline is
Col : constant Int := Column;
begin
Write_Eol;
while Col > Column loop
Write_Char ('-');
end loop;
Write_Eol;
end Underline;
begin
if Debug_Flag_Y then
Debug_Flag_Y := False;
Write_Eol;
Write_Str ("Tree created for Standard (spec) ");
Underline;
Print_Node_Subtree (Standard_Package_Node);
Write_Eol;
end if;
if Debug_Flag_T then
Debug_Flag_T := False;
Write_Eol;
Write_Str ("Tree created for ");
Write_Unit_Name (Unit_Name (Main_Unit));
Underline;
Print_Node_Subtree (Cunit (Main_Unit));
Write_Eol;
end if;
end Tree_Dump;
procedure Visit_Elist (E : Elist_Id; Prefix_Str : String) is
M : Elmt_Id;
N : Node_Id;
S : constant Nat := Serial_Number (Int (E));
begin
if Phase = Marking then
if S /= 0 then
return; else
Set_Serial_Number;
end if;
else
if S < Next_Serial_Number then
return; else
Next_Serial_Number := Next_Serial_Number + 1;
end if;
end if;
Print_Str (Prefix_Str);
Print_Elist_Ref (E);
Print_Eol;
if Is_Empty_Elmt_List (E) then
Print_Str (Prefix_Str);
Print_Str ("(Empty element list)");
Print_Eol;
Print_Eol;
else
if Phase = Printing then
M := First_Elmt (E);
while Present (M) loop
N := Node (M);
Print_Str (Prefix_Str);
Print_Str (" ");
Print_Node_Ref (N);
Print_Eol;
Next_Elmt (M);
end loop;
Print_Str (Prefix_Str);
Print_Eol;
end if;
M := First_Elmt (E);
while Present (M) loop
Visit_Node (Node (M), Prefix_Str, ' ');
Next_Elmt (M);
end loop;
end if;
end Visit_Elist;
procedure Visit_List (L : List_Id; Prefix_Str : String) is
N : Node_Id;
S : constant Nat := Serial_Number (Int (L));
begin
if Phase = Marking then
if S /= 0 then
return;
else
Set_Serial_Number;
end if;
else
if S < Next_Serial_Number then
return; else
Next_Serial_Number := Next_Serial_Number + 1;
end if;
end if;
Print_Str (Prefix_Str);
Print_List_Ref (L);
Print_Eol;
Print_Str (Prefix_Str);
Print_Str ("|Parent = ");
Print_Node_Ref (Parent (L));
Print_Eol;
N := First (L);
if N = Empty then
Print_Str (Prefix_Str);
Print_Str ("(Empty list)");
Print_Eol;
Print_Eol;
else
Print_Str (Prefix_Str);
Print_Char ('|');
Print_Eol;
while Next (N) /= Empty loop
Visit_Node (N, Prefix_Str, '|');
Next (N);
end loop;
end if;
Visit_Node (N, Prefix_Str, ' ');
end Visit_List;
procedure Visit_Node
(N : Node_Id;
Prefix_Str : String;
Prefix_Char : Character)
is
New_Prefix : String (Prefix_Str'First .. Prefix_Str'Last + 2);
procedure Visit_Descendent
(D : Union_Id;
No_Indent : Boolean := False);
procedure Visit_Descendent
(D : Union_Id;
No_Indent : Boolean := False)
is
begin
if D in Node_Range then
if D <= Union_Id (Empty_Or_Error) then
return;
end if;
declare
Nod : constant Node_Or_Entity_Id := Node_Or_Entity_Id (D);
begin
if Sloc (Nod) <= Standard_Location then
if Sloc (N) > Standard_Location
and then not Debug_Flag_F
then
return;
end if;
else
if (Sloc (N) <= Standard_Location
or else Sloc (N) = No_Location
or else Sloc (Nod) = No_Location
or else not In_Same_Source_Unit (Nod, N))
and then not Debug_Flag_F
then
return;
end if;
end if;
if Parent (Nod) /= Empty
and then Comes_From_Source (Nod)
and then Parent (Nod) /= N
and then (Sloc (N) > Standard_Location or else Debug_Flag_Y)
then
return;
end if;
if No_Indent then
Visit_Node (Nod, Prefix_Str, Prefix_Char);
else
Visit_Node (Nod, New_Prefix, ' ');
end if;
end;
elsif D in List_Range then
if D = Union_Id (No_List)
or else D = Union_Id (Error_List)
or else Is_Empty_List (List_Id (D))
then
return;
else
Visit_List (List_Id (D), New_Prefix);
end if;
elsif D in Elist_Range then
if D = Union_Id (No_Elist)
or else Is_Empty_Elmt_List (Elist_Id (D))
then
return;
else
Visit_Elist (Elist_Id (D), New_Prefix);
end if;
else
null;
end if;
end Visit_Descendent;
begin
if N = Empty then
return;
end if;
Current_Error_Node := N;
New_Prefix (Prefix_Str'Range) := Prefix_Str;
New_Prefix (Prefix_Str'Last + 1) := Prefix_Char;
New_Prefix (Prefix_Str'Last + 2) := ' ';
if Phase = Marking then
if Serial_Number (Int (N)) /= 0 then
return; else
Set_Serial_Number;
end if;
else
if Serial_Number (Int (N)) < Next_Serial_Number then
if Is_List_Member (N) then
Print_Str (Prefix_Str);
Print_Node_Ref (N);
Print_Eol;
Print_Str (Prefix_Str);
Print_Char (Prefix_Char);
Print_Str ("(already output)");
Print_Eol;
Print_Str (Prefix_Str);
Print_Char (Prefix_Char);
Print_Eol;
end if;
return;
else
Print_Node (N, Prefix_Str, Prefix_Char);
Print_Str (Prefix_Str);
Print_Char (Prefix_Char);
Print_Eol;
Next_Serial_Number := Next_Serial_Number + 1;
end if;
end if;
if Nkind (N) not in N_Entity then
Visit_Descendent (Field1 (N));
Visit_Descendent (Field2 (N));
Visit_Descendent (Field3 (N));
Visit_Descendent (Field4 (N));
Visit_Descendent (Field5 (N));
else
Visit_Descendent (Field1 (N));
Visit_Descendent (Field3 (N));
Visit_Descendent (Field4 (N));
Visit_Descendent (Field5 (N));
Visit_Descendent (Field6 (N));
Visit_Descendent (Field7 (N));
Visit_Descendent (Field8 (N));
Visit_Descendent (Field9 (N));
Visit_Descendent (Field10 (N));
Visit_Descendent (Field11 (N));
Visit_Descendent (Field12 (N));
Visit_Descendent (Field13 (N));
Visit_Descendent (Field14 (N));
Visit_Descendent (Field15 (N));
Visit_Descendent (Field16 (N));
Visit_Descendent (Field17 (N));
Visit_Descendent (Field18 (N));
Visit_Descendent (Field19 (N));
Visit_Descendent (Field20 (N));
Visit_Descendent (Field21 (N));
Visit_Descendent (Field22 (N));
Visit_Descendent (Field23 (N));
if not Comes_From_Source (N) then
Visit_Descendent (Union_Id (Parent (N)));
end if;
if Present (Next_Entity (N))
and then Present (Scope (N))
and then First_Entity (Scope (N)) = N
then
declare
Nod : Node_Id;
begin
Nod := N;
while Present (Nod) loop
Visit_Descendent (Union_Id (Next_Entity (Nod)));
Nod := Next_Entity (Nod);
end loop;
end;
end if;
end if;
end Visit_Node;
end Treepr;