home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / treepr.adb < prev    next >
Text File  |  1996-09-28  |  49KB  |  1,675 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                               T R E E P R                                --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.97 $                             --
  10. --                                                                          --
  11. --        Copyright (c) 1992,1993,1994,1995 NYU, All Rights Reserved        --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. --
  22. --                                                                          --
  23. ------------------------------------------------------------------------------
  24.  
  25. with Atree;   use Atree;
  26. with Csets;   use Csets;
  27. with Comperr; use Comperr;
  28. with Debug;   use Debug;
  29. with Einfo;   use Einfo;
  30. with Elists;  use Elists;
  31. with Itypes;  use Itypes;
  32. with Lib;     use Lib;
  33. with Namet;   use Namet;
  34. with Nlists;  use Nlists;
  35. with Output;  use Output;
  36. with Sinfo;   use Sinfo;
  37. with Snames;  use Snames;
  38. with Sinput;  use Sinput;
  39. with Stand;   use Stand;
  40. with Stringt; use Stringt;
  41. with Treeprs; use Treeprs;
  42. with Uintp;   use Uintp;
  43. with Urealp;  use Urealp;
  44. with Uname;   use Uname;
  45. with Unchecked_Deallocation;
  46.  
  47. package body Treepr is
  48.  
  49.    use Atree.Unchecked_Access;
  50.    --  This module uses the unchecked access functions in package Atree
  51.    --  since it does an untyped traversal of the tree (we do not want to
  52.    --  count on the structure of the tree being correct in this routine!)
  53.  
  54.    ----------------------------------
  55.    -- Approach Used for Tree Print --
  56.    ----------------------------------
  57.  
  58.    --  When a complete subtree is being printed, a trace phase first marks
  59.    --  the nodes and lists to be printed. This trace phase allocates logical
  60.    --  numbers corresponding to the order in which the nodes and lists will
  61.    --  be printed. The Node_Id, List_Id and Elist_Id values are mapped to
  62.    --  logical node numbers using a hash table. Output is done using a set
  63.    --  of Print_xxx routines, which are similar to the Write_xxx routines
  64.    --  with the same name, except that they do not generate any output in
  65.    --  the marking phase. This allows identical logic to be used in the
  66.    --  two phases.
  67.  
  68.    --  Note that the hash table not only holds the serial numbers, but also
  69.    --  acts as a record of which nodes have already been visited. In the
  70.    --  marking phase, a node has been visited if it is already in the hash
  71.    --  table, and in the printing phase, we can tell whether a node has
  72.    --  already been printed by looking at the value of the serial number.
  73.  
  74.    ----------------------
  75.    -- Global Variables --
  76.    ----------------------
  77.  
  78.    type Hash_Record is record
  79.       Serial : Nat;
  80.       --  Serial number for hash table entry. A value of zero means that
  81.       --  the entry is currently unused.
  82.  
  83.       Id : Int;
  84.       --  If serial number field is non-zero, contains corresponding Id value
  85.    end record;
  86.  
  87.    type Hash_Table_Type is array (Nat range <>) of Hash_Record;
  88.    type Access_Hash_Table_Type is access Hash_Table_Type;
  89.    Hash_Table : Access_Hash_Table_Type;
  90.    --  The hash table itself, see Serial_Number function for details of use
  91.  
  92.    Hash_Table_Len : Nat;
  93.    --  Range of Hash_Table is from 0 .. Hash_Table_Len - 1 so that dividing
  94.    --  by Hash_Table_Len gives a remainder that is in Hash_Table'Range.
  95.  
  96.    Next_Serial_Number : Nat;
  97.    --  Number of last visited node or list. Used during the marking phase to
  98.    --  set proper node numbers in the hash table, and during the printing
  99.    --  phase to make sure that a given node is not printed more than once.
  100.    --  (nodes are printed in order during the printing phase, that's the
  101.    --  point of numbering them in the first place!)
  102.  
  103.    Printing_Descendants : Boolean;
  104.    --  True if descendants are being printed, False if not. In the false case,
  105.    --  only node Id's are printed. In the true case, node numbers as well as
  106.    --  node Id's are printed, as described above.
  107.  
  108.    type Phase_Type is (Marking, Printing);
  109.    --  Type for Phase variable
  110.  
  111.    Phase : Phase_Type;
  112.    --  When an entire tree is being printed, the traversal operates in two
  113.    --  phases. The first phase marks the nodes in use by installing node
  114.    --  numbers in the node number table. The second phase prints the nodes.
  115.    --  This variable indicates the current phase.
  116.  
  117.    ----------------------
  118.    -- Local Procedures --
  119.    ----------------------
  120.  
  121.    procedure Print_Init;
  122.    --  Initialize for printing of tree with descendents
  123.  
  124.    procedure Print_Term;
  125.    --  Clean up after printing of tree with descendents
  126.  
  127.    procedure Print_Char (C : Character);
  128.    --  Print character C if currently in print phase, noop if in marking phase
  129.  
  130.    procedure Print_Name (N : Name_Id);
  131.    --  Print name from names table if currently in print phase, noop if in
  132.    --  marking phase. Note that the name is output in mixed case mode.
  133.  
  134.    procedure Print_Node_Kind (N : Node_Id);
  135.    --  Print node kind name in mixed case if in print phase, noop if in
  136.    --  marking phase.
  137.  
  138.    procedure Print_Str (S : String);
  139.    --  Print string S if currently in print phase, noop if in marking phase
  140.  
  141.    procedure Print_Str_Mixed_Case (S : String);
  142.    --  Like Print_Str, except that the string is printed in mixed case mode
  143.  
  144.    procedure Print_Int (I : Int);
  145.    --  Print integer I if currently in print phase, noop if in marking phase
  146.  
  147.    procedure Print_Eol;
  148.    --  Print end of line if currently in print phase, noop if in marking phase
  149.  
  150.    procedure Print_Node_Ref (N : Node_Id);
  151.    --  Print "<empty>", "<error>" or "Node #nnn" with additional information
  152.    --  in the latter case, including the Id and the Nkind of the node.
  153.  
  154.    procedure Print_List_Ref (L : List_Id);
  155.    --  Print "<no list>", or "<empty node list>" or "Node list #nnn"
  156.  
  157.    procedure Print_Elist_Ref (E : Elist_Id);
  158.    --  Print "<no elist>", or "<empty element list>" or "Element list #nnn"
  159.  
  160.    procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String);
  161.    --  Called if the node being printed is an entity. Prints fields from the
  162.    --  extension, using routines in Einfo to get the field names and flags.
  163.  
  164.    procedure Print_Field (Val : Union_Id);
  165.    --  Print representation of Field value (name, tree, string, uint, charcode)
  166.  
  167.    procedure Print_Flag (F : Boolean);
  168.    --  Print True or False
  169.  
  170.    procedure Print_Node
  171.      (N           : Node_Id;
  172.       Prefix_Str  : String;
  173.       Prefix_Char : Character);
  174.    --  This is the internal routine used to print a single node. Each line of
  175.    --  output is preceded by Prefix_Str (which is used to set the indentation
  176.    --  level and the bars used to link list elements). In addition, for lines
  177.    --  other than the first, an additional character Prefix_Char is output.
  178.  
  179.    function Serial_Number (Id : Int) return Nat;
  180.    --  Given a Node_Id, List_Id or Elist_Id, returns the previously assigned
  181.    --  serial number, or zero if no serial number has yet been assigned.
  182.  
  183.    procedure Set_Serial_Number;
  184.    --  Can be called only immediately following a call to Serial_Number that
  185.    --  returned a value of zero. Causes the value of Next_Serial_Number to be
  186.    --  placed in the hash table (corresponding to the Id argument used in the
  187.    --  Serial_Number call), and increments Next_Serial_Number.
  188.  
  189.    procedure Visit_Node
  190.      (N           : Node_Id;
  191.       Prefix_Str  : String;
  192.       Prefix_Char : Character);
  193.    --  Called to process a single node in the case where descendents are to
  194.    --  be printed before every line, and Prefix_Char added to all lines
  195.    --  except the header line for the node.
  196.  
  197.    procedure Visit_List (L : List_Id; Prefix_Str : String);
  198.    --  Visit_List is called to process a list in the case where descendents
  199.    --  are to be printed. Prefix_Str is to be added to all printed lines.
  200.  
  201.    procedure Visit_Elist (E : Elist_Id; Prefix_Str : String);
  202.    --  Visit_Elist is called to process an element list in the case where
  203.    --  descendents are to be printed. Prefix_Str is to be added to all
  204.    --  printed lines.
  205.  
  206.    ---------------
  207.    -- Tree_Dump --
  208.    ---------------
  209.  
  210.    procedure Tree_Dump is
  211.       Max_Unit : Unit_Number_Type;
  212.  
  213.       procedure Underline;
  214.       --  Put underline under string we just printed
  215.  
  216.       procedure Underline is
  217.          Col : constant Int := Column;
  218.  
  219.       begin
  220.          Write_Eol;
  221.  
  222.          while Col > Column loop
  223.             Write_Char ('-');
  224.          end loop;
  225.  
  226.          Write_Eol;
  227.       end Underline;
  228.  
  229.    --  Start of processing for Tree_Dump. Note that we turn off the tree dump
  230.    --  flags immediately, before starting the dump. This avoids generating two
  231.    --  copies of the dump if an abort occurs after printing the dump, and more
  232.    --  importantly, avoids an infinite loop if an abort occurs during the dump.
  233.  
  234.    --  Note: unlike in the source print case (in Sprint), we do not output
  235.    --  separate trees for each unit. Instead the -df debug switch causes the
  236.    --  tree that is output from the main unit to trace references into other
  237.    --  units (normally such references are not traced). Since all other units
  238.    --  are linked to the main unit by at least one reference, this causes all
  239.    --  tree nodes to be included in the output tree.
  240.  
  241.    begin
  242.       if Debug_Flag_Y then
  243.          Debug_Flag_Y := False;
  244.          Write_Eol;
  245.          Write_Str ("Tree created for Standard (spec) ");
  246.          Underline;
  247.          Print_Node_Subtree (Standard_Package_Node);
  248.          Write_Eol;
  249.       end if;
  250.  
  251.       if Debug_Flag_T then
  252.          Debug_Flag_T := False;
  253.  
  254.          Write_Eol;
  255.          Write_Str ("Tree created for ");
  256.          Write_Unit_Name (Unit_Name (Main_Unit));
  257.          Underline;
  258.          Print_Node_Subtree (Cunit (Main_Unit));
  259.          Write_Eol;
  260.       end if;
  261.  
  262.    end Tree_Dump;
  263.  
  264.    ---------------------
  265.    -- Print_Tree_Node --
  266.    ---------------------
  267.  
  268.    procedure Print_Tree_Node (N : Node_Id; Label : String := "") is
  269.    begin
  270.       Printing_Descendants := False;
  271.       Phase := Printing;
  272.       Print_Node (N, Label, ' ');
  273.    end Print_Tree_Node;
  274.  
  275.    ---------------------
  276.    -- Print_Tree_List --
  277.    ---------------------
  278.  
  279.    procedure Print_Tree_List (L : List_Id) is
  280.       N : Node_Id;
  281.  
  282.    begin
  283.       Printing_Descendants := False;
  284.       Phase := Printing;
  285.  
  286.       Print_List_Ref (L);
  287.       Print_Str (" List_Id=");
  288.       Print_Int (Int (L));
  289.       Print_Eol;
  290.  
  291.       N := First (L);
  292.  
  293.       if N = Empty then
  294.          Print_Str ("<empty node list>");
  295.          Print_Eol;
  296.  
  297.       else
  298.          loop
  299.             Print_Char ('|');
  300.             Print_Eol;
  301.             exit when Next (N) = Empty;
  302.             Print_Node (N, "", '|');
  303.             N := Next (N);
  304.          end loop;
  305.  
  306.          Print_Node (N, "", ' ');
  307.          Print_Eol;
  308.       end if;
  309.    end Print_Tree_List;
  310.  
  311.    ---------------------
  312.    -- Print_Tree_Elist --
  313.    ---------------------
  314.  
  315.    procedure Print_Tree_Elist (E : Elist_Id) is
  316.       M : Elmt_Id;
  317.  
  318.    begin
  319.       Printing_Descendants := False;
  320.       Phase := Printing;
  321.  
  322.       Print_Elist_Ref (E);
  323.       Print_Eol;
  324.  
  325.       M := First_Elmt (E);
  326.  
  327.       if No (M) then
  328.          Print_Str ("<empty element list>");
  329.          Print_Eol;
  330.  
  331.       else
  332.          loop
  333.             Print_Char ('|');
  334.             Print_Eol;
  335.             exit when No (Next_Elmt (M));
  336.             Print_Node (Node (M), "", '|');
  337.             M := Next_Elmt (M);
  338.          end loop;
  339.  
  340.          Print_Node (Node (M), "", ' ');
  341.          Print_Eol;
  342.       end if;
  343.    end Print_Tree_Elist;
  344.  
  345.    ----------------
  346.    -- Print_Init --
  347.    ----------------
  348.  
  349.    procedure Print_Init is
  350.    begin
  351.       Printing_Descendants := True;
  352.       Write_Eol;
  353.  
  354.       --  Allocate and clear serial number hash table. The size is 150% of
  355.       --  the maximum possible number of entries, so that the hash table
  356.       --  cannot get significantly overloaded.
  357.  
  358.       Hash_Table_Len := (150 * (Num_Nodes + Num_Lists + Num_Elists)) / 100;
  359.       Hash_Table := new Hash_Table_Type  (0 .. Hash_Table_Len - 1);
  360.  
  361.       for J in Hash_Table'Range loop
  362.          Hash_Table (J).Serial := 0;
  363.       end loop;
  364.  
  365.    end Print_Init;
  366.  
  367.    ----------------
  368.    -- Print_Term --
  369.    ----------------
  370.  
  371.    procedure Print_Term is
  372.       procedure Free is new Unchecked_Deallocation
  373.         (Hash_Table_Type, Access_Hash_Table_Type);
  374.  
  375.    begin
  376.       Free (Hash_Table);
  377.    end Print_Term;
  378.  
  379.    ------------------------
  380.    -- Print_Node_Subtree --
  381.    ------------------------
  382.  
  383.    procedure Print_Node_Subtree (N : Node_Id) is
  384.    begin
  385.       Print_Init;
  386.  
  387.       Next_Serial_Number := 1;
  388.       Phase := Marking;
  389.       Visit_Node (N, "", ' ');
  390.  
  391.       Next_Serial_Number := 1;
  392.       Phase := Printing;
  393.       Visit_Node (N, "", ' ');
  394.  
  395.       Print_Term;
  396.    end Print_Node_Subtree;
  397.  
  398.    ------------------------
  399.    -- Print_List_Subtree --
  400.    ------------------------
  401.  
  402.    procedure Print_List_Subtree (L : List_Id) is
  403.    begin
  404.       Print_Init;
  405.  
  406.       Next_Serial_Number := 1;
  407.       Phase := Marking;
  408.       Visit_List (L, "");
  409.  
  410.       Next_Serial_Number := 1;
  411.       Phase := Printing;
  412.       Visit_List (L, "");
  413.  
  414.       Print_Term;
  415.    end Print_List_Subtree;
  416.  
  417.    -------------------------
  418.    -- Print_Elist_Subtree --
  419.    -------------------------
  420.  
  421.    procedure Print_Elist_Subtree (E : Elist_Id) is
  422.    begin
  423.       Print_Init;
  424.  
  425.       Next_Serial_Number := 1;
  426.       Phase := Marking;
  427.       Visit_Elist (E, "");
  428.  
  429.       Next_Serial_Number := 1;
  430.       Phase := Printing;
  431.       Visit_Elist (E, "");
  432.  
  433.       Print_Term;
  434.    end Print_Elist_Subtree;
  435.  
  436.    ----------------
  437.    -- Print_Char --
  438.    ----------------
  439.  
  440.    procedure Print_Char (C : Character) is
  441.    begin
  442.       if Phase = Printing then
  443.          Write_Char (C);
  444.       end if;
  445.    end Print_Char;
  446.  
  447.    -----------------------
  448.    -- Print_Entity_Info --
  449.    -----------------------
  450.  
  451.    procedure Print_Entity_Info (Ent : Entity_Id; Prefix : String) is
  452.       function Field_Present (U : Union_Id) return Boolean;
  453.       --  Returns False unless the value U represents a missing value
  454.       --  (Empty, No_Uint, No_Ureal or No_String)
  455.  
  456.       function Field_Present (U : Union_Id) return Boolean is
  457.       begin
  458.          return
  459.             U /= Union_Id (Empty)    and then
  460.             U /= To_Union (No_Uint)  and then
  461.             U /= To_Union (No_Ureal) and then
  462.             U /= Union_Id (No_String);
  463.       end Field_Present;
  464.  
  465.    --  Start of processing for Print_Entity_Info
  466.  
  467.    begin
  468.       Print_Str (Prefix);
  469.       Print_Str ("Ekind = ");
  470.       Print_Str_Mixed_Case (Entity_Kind'Image (Ekind (Ent)));
  471.       Print_Eol;
  472.  
  473.       Print_Str (Prefix);
  474.       Print_Str ("Etype = ");
  475.       Print_Node_Ref (Etype (Ent));
  476.       Print_Eol;
  477.  
  478.       if Convention (Ent) /= Convention_Ada then
  479.          Print_Str (Prefix);
  480.          Print_Str ("Convention = ");
  481.  
  482.          --  Print convention name skipping the Convention_ at the start
  483.  
  484.          declare
  485.             S : constant String := Convention_Id'Image (Convention (Ent));
  486.  
  487.          begin
  488.             Print_Str_Mixed_Case (S (12 .. S'Last));
  489.             Print_Eol;
  490.          end;
  491.       end if;
  492.  
  493.       if Field_Present (Field6 (Ent)) then
  494.          Print_Str (Prefix);
  495.          Write_Field6_Name (Ent);
  496.          Write_Str (" = ");
  497.          Print_Field (Field6 (Ent));
  498.          Print_Eol;
  499.       end if;
  500.  
  501.       if Field_Present (Field7 (Ent)) then
  502.          Print_Str (Prefix);
  503.          Write_Field7_Name (Ent);
  504.          Write_Str (" = ");
  505.          Print_Field (Field7 (Ent));
  506.          Print_Eol;
  507.       end if;
  508.  
  509.       if Field_Present (Field8 (Ent)) then
  510.          Print_Str (Prefix);
  511.          Write_Field8_Name (Ent);
  512.          Write_Str (" = ");
  513.          Print_Field (Field8 (Ent));
  514.          Print_Eol;
  515.       end if;
  516.  
  517.       if Field_Present (Field9 (Ent)) then
  518.          Print_Str (Prefix);
  519.          Write_Field9_Name (Ent);
  520.          Write_Str (" = ");
  521.          Print_Field (Field9 (Ent));
  522.          Print_Eol;
  523.       end if;
  524.  
  525.       if Field_Present (Field10 (Ent)) then
  526.          Print_Str (Prefix);
  527.          Write_Field10_Name (Ent);
  528.          Write_Str (" = ");
  529.          Print_Field (Field10 (Ent));
  530.          Print_Eol;
  531.       end if;
  532.  
  533.       if Field_Present (Field11 (Ent)) then
  534.          Print_Str (Prefix);
  535.          Write_Field11_Name (Ent);
  536.          Write_Str (" = ");
  537.          Print_Field (Field11 (Ent));
  538.          Print_Eol;
  539.       end if;
  540.  
  541.       if Field_Present (Field12 (Ent)) then
  542.          Print_Str (Prefix);
  543.          Write_Field12_Name (Ent);
  544.          Write_Str (" = ");
  545.          Print_Field (Field12 (Ent));
  546.          Print_Eol;
  547.       end if;
  548.  
  549.       if Field_Present (Field13 (Ent)) then
  550.          Print_Str (Prefix);
  551.          Write_Field13_Name (Ent);
  552.          Write_Str (" = ");
  553.          Print_Field (Field13 (Ent));
  554.          Print_Eol;
  555.       end if;
  556.  
  557.       if Field_Present (Field14 (Ent)) then
  558.          Print_Str (Prefix);
  559.          Write_Field14_Name (Ent);
  560.          Write_Str (" = ");
  561.          Print_Field (Field14 (Ent));
  562.          Print_Eol;
  563.       end if;
  564.  
  565.       if Field_Present (Field15 (Ent)) then
  566.          Print_Str (Prefix);
  567.          Write_Field15_Name (Ent);
  568.          Write_Str (" = ");
  569.          Print_Field (Field15 (Ent));
  570.          Print_Eol;
  571.       end if;
  572.  
  573.       if Field_Present (Field16 (Ent)) then
  574.          Print_Str (Prefix);
  575.          Write_Field16_Name (Ent);
  576.          Write_Str (" = ");
  577.          Print_Field (Field16 (Ent));
  578.          Print_Eol;
  579.       end if;
  580.  
  581.       if Field_Present (Field17 (Ent)) then
  582.          Print_Str (Prefix);
  583.          Write_Field17_Name (Ent);
  584.          Write_Str (" = ");
  585.          Print_Field (Field17 (Ent));
  586.          Print_Eol;
  587.       end if;
  588.  
  589.       if Field_Present (Field18 (Ent)) then
  590.          Print_Str (Prefix);
  591.          Write_Field18_Name (Ent);
  592.          Write_Str (" = ");
  593.          Print_Field (Field18 (Ent));
  594.          Print_Eol;
  595.       end if;
  596.  
  597.       if Field_Present (Field19 (Ent)) then
  598.          Print_Str (Prefix);
  599.          Write_Field19_Name (Ent);
  600.          Write_Str (" = ");
  601.          Print_Field (Field19 (Ent));
  602.          Print_Eol;
  603.       end if;
  604.  
  605.       if Field_Present (Field20 (Ent)) then
  606.          Print_Str (Prefix);
  607.          Write_Field20_Name (Ent);
  608.          Write_Str (" = ");
  609.          Print_Field (Field20 (Ent));
  610.          Print_Eol;
  611.       end if;
  612.  
  613.       if Field_Present (Field21 (Ent)) then
  614.          Print_Str (Prefix);
  615.          Write_Field21_Name (Ent);
  616.          Write_Str (" = ");
  617.          Print_Field (Field21 (Ent));
  618.          Print_Eol;
  619.       end if;
  620.  
  621.       if Field_Present (Field22 (Ent)) then
  622.          Print_Str (Prefix);
  623.          Write_Field22_Name (Ent);
  624.          Write_Str (" = ");
  625.          Print_Field (Field22 (Ent));
  626.          Print_Eol;
  627.       end if;
  628.  
  629.       Write_Entity_Flags (Ent, Prefix);
  630.  
  631.    end Print_Entity_Info;
  632.  
  633.    ---------------
  634.    -- Print_Int --
  635.    ---------------
  636.  
  637.    procedure Print_Int (I : Int) is
  638.    begin
  639.       if Phase = Printing then
  640.          Write_Int (I);
  641.       end if;
  642.    end Print_Int;
  643.  
  644.    ----------------
  645.    -- Print_Name --
  646.    ----------------
  647.  
  648.    procedure Print_Name (N : Name_Id) is
  649.    begin
  650.       if Phase = Printing then
  651.          if N = No_Name then
  652.             Print_Str ("<No_Name>");
  653.  
  654.          elsif N = Error_Name then
  655.             Print_Str ("<Error_Name>");
  656.  
  657.          else
  658.             Get_Name_String (N);
  659.             Print_Char ('"');
  660.             Write_Name (N);
  661.             Print_Char ('"');
  662.          end if;
  663.       end if;
  664.    end Print_Name;
  665.  
  666.    ---------------------
  667.    -- Print_Node_Kind --
  668.    ---------------------
  669.  
  670.    procedure Print_Node_Kind (N : Node_Id) is
  671.       Ucase : Boolean;
  672.       S     : constant String := Node_Kind'Image (Nkind (N));
  673.  
  674.    begin
  675.       if Phase = Printing then
  676.          Ucase := True;
  677.  
  678.          --  Note: the call to Fold_Upper in this loop is to get past the GNAT
  679.          --  bug of 'Image returning lower case instead of upper case.
  680.  
  681.          for J in S'Range loop
  682.             if Ucase then
  683.                Write_Char (Fold_Upper (S (J)));
  684.             else
  685.                Write_Char (Fold_Lower (S (J)));
  686.             end if;
  687.  
  688.             Ucase := (S (J) = '_');
  689.          end loop;
  690.       end if;
  691.    end Print_Node_Kind;
  692.  
  693.    ---------------
  694.    -- Print_Str --
  695.    ---------------
  696.  
  697.    procedure Print_Str (S : String) is
  698.    begin
  699.       if Phase = Printing then
  700.          Write_Str (S);
  701.       end if;
  702.    end Print_Str;
  703.  
  704.    --------------------------
  705.    -- Print_Str_Mixed_Case --
  706.    --------------------------
  707.  
  708.    procedure Print_Str_Mixed_Case (S : String) is
  709.       Ucase : Boolean;
  710.  
  711.    begin
  712.       if Phase = Printing then
  713.          Ucase := True;
  714.  
  715.          for J in S'Range loop
  716.             if Ucase then
  717.                Write_Char (S (J));
  718.             else
  719.                Write_Char (Fold_Lower (S (J)));
  720.             end if;
  721.  
  722.             Ucase := (S (J) = '_');
  723.          end loop;
  724.       end if;
  725.    end Print_Str_Mixed_Case;
  726.  
  727.    ---------------
  728.    -- Print_Eol --
  729.    ---------------
  730.  
  731.    procedure Print_Eol is
  732.    begin
  733.       if Phase = Printing then
  734.          Write_Eol;
  735.       end if;
  736.    end Print_Eol;
  737.  
  738.    --------------------
  739.    -- Print_Node_Ref --
  740.    --------------------
  741.  
  742.    procedure Print_Node_Ref (N : Node_Id) is
  743.       S : Nat;
  744.  
  745.    begin
  746.       if Phase /= Printing then
  747.          return;
  748.       end if;
  749.  
  750.       if N = Empty then
  751.          Write_Str ("<empty>");
  752.  
  753.       elsif N = Error then
  754.          Write_Str ("<error>");
  755.  
  756.       else
  757.          if Printing_Descendants then
  758.             S := Serial_Number (Int (N));
  759.  
  760.             if S /= 0 then
  761.                Write_Str ("Node");
  762.                Write_Str (" #");
  763.                Write_Int (S);
  764.                Write_Char (' ');
  765.             end if;
  766.          end if;
  767.  
  768.          Print_Node_Kind (N);
  769.  
  770.          if Nkind (N) in N_Has_Chars then
  771.             Write_Char (' ');
  772.             Print_Name (Chars (N));
  773.          end if;
  774.  
  775.          if Nkind (N) in N_Entity then
  776.             Write_Str (" (Entity_Id=");
  777.          else
  778.             Write_Str (" (Node_Id=");
  779.          end if;
  780.  
  781.          Write_Int (Int (N));
  782.  
  783.          if Sloc (N) <= Standard_Location then
  784.             Write_Char ('s');
  785.          end if;
  786.  
  787.          Write_Char (')');
  788.  
  789.       end if;
  790.    end Print_Node_Ref;
  791.  
  792.    --------------------
  793.    -- Print_List_Ref --
  794.    --------------------
  795.  
  796.    procedure Print_List_Ref (L : List_Id) is
  797.    begin
  798.       if Phase /= Printing then
  799.          return;
  800.       end if;
  801.  
  802.       if No (L) then
  803.          Write_Str ("<no list>");
  804.  
  805.       elsif Is_Empty_List (L) then
  806.          Write_Str ("<empty list> (List_Id=");
  807.          Write_Int (Int (L));
  808.          Write_Char (')');
  809.  
  810.       else
  811.          Write_Str ("List");
  812.  
  813.          if Printing_Descendants then
  814.             Write_Str (" #");
  815.             Write_Int (Serial_Number (Int (L)));
  816.          end if;
  817.  
  818.          Write_Str (" (List_Id=");
  819.          Write_Int (Int (L));
  820.          Write_Char (')');
  821.       end if;
  822.    end Print_List_Ref;
  823.  
  824.    ---------------------
  825.    -- Print_Elist_Ref --
  826.    ---------------------
  827.  
  828.    procedure Print_Elist_Ref (E : Elist_Id) is
  829.    begin
  830.       if Phase /= Printing then
  831.          return;
  832.       end if;
  833.  
  834.       if E = No_Elist then
  835.          Write_Str ("<no elist>");
  836.  
  837.       elsif Is_Empty_Elmt_List (E) then
  838.          Write_Str ("Empty elist, (Elist_Id=");
  839.          Write_Int (Int (E));
  840.          Write_Char (')');
  841.  
  842.       else
  843.          Write_Str ("(Elist_Id=");
  844.          Write_Int (Int (E));
  845.          Write_Char (')');
  846.  
  847.          if Printing_Descendants then
  848.             Write_Str (" #");
  849.             Write_Int (Serial_Number (Int (E)));
  850.          end if;
  851.       end if;
  852.    end Print_Elist_Ref;
  853.  
  854.    -----------------
  855.    -- Print_Field --
  856.    -----------------
  857.  
  858.    procedure Print_Field (Val : Union_Id) is
  859.    begin
  860.       if Phase /= Printing then
  861.          return;
  862.       end if;
  863.  
  864.       if Val in Node_Range then
  865.          Print_Node_Ref (Node_Id (Val));
  866.  
  867.       elsif Val in List_Range then
  868.          Print_List_Ref (List_Id (Val));
  869.  
  870.       elsif Val in Elist_Range then
  871.          Print_Elist_Ref (Elist_Id (Val));
  872.  
  873.       elsif Val in Names_Range then
  874.          Print_Name (Name_Id (Val));
  875.          Write_Str (" (Name_Id=");
  876.          Write_Int (Int (Val));
  877.          Write_Char (')');
  878.  
  879.       elsif Val in Strings_Range then
  880.          Write_String_Table_Entry (String_Id (Val));
  881.          Write_Str (" (String_Id=");
  882.          Write_Int (Int (Val));
  883.          Write_Char (')');
  884.  
  885.       elsif Val in Uint_Range then
  886.          UI_Write (From_Union (Val));
  887.          Write_Str (" (Uint = ");
  888.          Write_Int (Int (Val));
  889.          Write_Char (')');
  890.  
  891.       elsif Val in Ureal_Range then
  892.          UR_Write (From_Union (Val));
  893.          Write_Str (" (Ureal = ");
  894.          Write_Int (Int (Val));
  895.          Write_Char (')');
  896.  
  897.       elsif Val in Char_Code_Range then
  898.          Write_Str ("Character code = ");
  899.  
  900.          declare
  901.             C : Char_Code := Char_Code (Val - Char_Code_Bias);
  902.  
  903.          begin
  904.             Write_Int (Int (C));
  905.             Write_Str (" ('");
  906.             Write_Char_Code (C);
  907.             Write_Str ("')");
  908.          end;
  909.  
  910.       else
  911.          Print_Str ("****** Incorrect value = ");
  912.          Print_Int (Int (Val));
  913.       end if;
  914.    end Print_Field;
  915.  
  916.    ----------------
  917.    -- Print_Flag --
  918.    ----------------
  919.  
  920.    procedure Print_Flag (F : Boolean) is
  921.    begin
  922.       if F then
  923.          Print_Str ("True");
  924.       else
  925.          Print_Str ("False");
  926.       end if;
  927.    end Print_Flag;
  928.  
  929.    ----------------
  930.    -- Print_Node --
  931.    ----------------
  932.  
  933.    procedure Print_Node
  934.      (N           : Node_Id;
  935.       Prefix_Str  : String;
  936.       Prefix_Char : Character)
  937.    is
  938.       F : Fchar;
  939.       P : Natural := Pchar_Pos (Nkind (N));
  940.  
  941.       Field_To_Be_Printed : Boolean;
  942.       Prefix_Str_Char     : String (Prefix_Str'First .. Prefix_Str'Last + 1);
  943.       Sfile               : Source_File_Index;
  944.       Notes               : Boolean;
  945.  
  946.    begin
  947.       if Phase /= Printing then
  948.          return;
  949.       end if;
  950.  
  951.       Prefix_Str_Char (Prefix_Str'Range)    := Prefix_Str;
  952.       Prefix_Str_Char (Prefix_Str'Last + 1) := Prefix_Char;
  953.  
  954.       --  Print header line
  955.  
  956.       Print_Str (Prefix_Str);
  957.       Print_Node_Ref (N);
  958.  
  959.       --  Print note if standard fields set
  960.  
  961.       Notes := False;
  962.  
  963.       if Comes_From_Source (N) then
  964.          Notes := True;
  965.          Print_Str (" (source");
  966.       end if;
  967.  
  968.       if Analyzed (N) then
  969.          if not Notes then
  970.             Notes := True;
  971.             Print_Str (" (");
  972.          else
  973.             Print_Str (",");
  974.          end if;
  975.  
  976.          Print_Str ("analyzed");
  977.       end if;
  978.  
  979.       if Error_Posted (N) then
  980.          if not Notes then
  981.             Notes := True;
  982.             Print_Str (" (");
  983.          else
  984.             Print_Str (",");
  985.          end if;
  986.  
  987.          Print_Str ("posted");
  988.       end if;
  989.  
  990.       if Notes then
  991.          Print_Char (')');
  992.       end if;
  993.  
  994.       Print_Eol;
  995.  
  996.       if N = Empty then
  997.          return;
  998.       end if;
  999.  
  1000.       if not Is_List_Member (N) then
  1001.          Print_Str (Prefix_Str);
  1002.          Print_Str (" Parent = ");
  1003.          Print_Node_Ref (Parent (N));
  1004.          Print_Eol;
  1005.       end if;
  1006.  
  1007.       --  Print Sloc field if it is set
  1008.  
  1009.       if Sloc (N) /= No_Location then
  1010.          Print_Str (Prefix_Str_Char);
  1011.          Print_Str ("Sloc = ");
  1012.  
  1013.          if Sloc (N) = Standard_Location then
  1014.             Print_Str ("Standard_Location");
  1015.  
  1016.          elsif Sloc (N) = Standard_Ascii_Location then
  1017.             Print_Str ("Standard_Ascii_Location");
  1018.  
  1019.          else
  1020.             Sfile := Get_Source_File_Index (Sloc (N));
  1021.             Print_Int (Int (Sloc (N)) - Int (Source_Text (Sfile)'First));
  1022.             Write_Str ("  ");
  1023.             Write_Location (Sloc (N));
  1024.          end if;
  1025.  
  1026.          Print_Eol;
  1027.       end if;
  1028.  
  1029.       --  Print Chars field if present
  1030.  
  1031.       if Nkind (N) in N_Has_Chars and then Chars (N) /= No_Name then
  1032.          Print_Str (Prefix_Str_Char);
  1033.          Print_Str ("Chars = ");
  1034.          Print_Name (Chars (N));
  1035.          Write_Str (" (Name_Id=");
  1036.          Write_Int (Int (Chars (N)));
  1037.          Write_Char (')');
  1038.          Print_Eol;
  1039.       end if;
  1040.  
  1041.       --  Special field print operations for non-entity nodes
  1042.  
  1043.       if Nkind (N) not in N_Entity then
  1044.  
  1045.          --  Deal with Left_Opnd and Right_Opnd fields
  1046.  
  1047.          if Nkind (N) in N_Op
  1048.            or else Nkind (N) = N_And_Then
  1049.            or else Nkind (N) = N_In
  1050.            or else Nkind (N) = N_Not_In
  1051.            or else Nkind (N) = N_Or_Else
  1052.          then
  1053.             --  Print Left_Opnd if present
  1054.  
  1055.             if Nkind (N) not in N_Unary_Op then
  1056.                Print_Str (Prefix_Str_Char);
  1057.                Print_Str ("Left_Opnd = ");
  1058.                Print_Node_Ref (Left_Opnd (N));
  1059.                Print_Eol;
  1060.             end if;
  1061.  
  1062.             --   Print Right_Opnd
  1063.  
  1064.             Print_Str (Prefix_Str_Char);
  1065.             Print_Str ("Right_Opnd = ");
  1066.             Print_Node_Ref (Right_Opnd (N));
  1067.             Print_Eol;
  1068.          end if;
  1069.  
  1070.          --  Print Entity field if operator (other cases of Entity
  1071.          --  are in the table, so are handled in the normal circuit)
  1072.  
  1073.          if Nkind (N) in N_Op and then Present (Entity (N)) then
  1074.             Print_Str (Prefix_Str_Char);
  1075.             Print_Str ("Entity = ");
  1076.             Print_Node_Ref (Entity (N));
  1077.             Print_Eol;
  1078.          end if;
  1079.  
  1080.          --  Print special fields if we have a subexpression
  1081.  
  1082.          if Nkind (N) in N_Subexpr then
  1083.  
  1084.             if Assignment_OK (N) then
  1085.                Print_Str (Prefix_Str_Char);
  1086.                Print_Str ("Assignment_OK = True");
  1087.                Print_Eol;
  1088.             end if;
  1089.  
  1090.             if Cannot_Be_Constant (N) then
  1091.                Print_Str (Prefix_Str_Char);
  1092.                Print_Str ("Cannot_Be_Constant = True");
  1093.                Print_Eol;
  1094.             end if;
  1095.  
  1096.             if Do_Range_Check (N) then
  1097.                Print_Str (Prefix_Str_Char);
  1098.                Print_Str ("Do_Range_Check = True");
  1099.                Print_Eol;
  1100.             end if;
  1101.  
  1102.             if Has_No_Side_Effects (N) then
  1103.                Print_Str (Prefix_Str_Char);
  1104.                Print_Str ("Has_No_Side_Effects = True");
  1105.                Print_Eol;
  1106.             end if;
  1107.  
  1108.             if Is_Controlling_Actual (N) then
  1109.                Print_Str (Prefix_Str_Char);
  1110.                Print_Str ("Is_Controlling_Actual = True");
  1111.                Print_Eol;
  1112.             end if;
  1113.  
  1114.             if Is_Overloaded (N) then
  1115.                Print_Str (Prefix_Str_Char);
  1116.                Print_Str ("Is_Overloaded = True");
  1117.                Print_Eol;
  1118.             end if;
  1119.  
  1120.             if Is_Static_Expression (N) then
  1121.                Print_Str (Prefix_Str_Char);
  1122.                Print_Str ("Is_Static_Expression = True");
  1123.                Print_Eol;
  1124.             end if;
  1125.  
  1126.             if Paren_Count (N) /= 0 then
  1127.                Print_Str (Prefix_Str_Char);
  1128.                Print_Str ("Paren_Count = ");
  1129.                Print_Int (Int (Paren_Count (N)));
  1130.                Print_Eol;
  1131.             end if;
  1132.  
  1133.             if Raises_Constraint_Error (N) then
  1134.                Print_Str (Prefix_Str_Char);
  1135.                Print_Str ("Raise_Constraint_Error = True");
  1136.                Print_Eol;
  1137.             end if;
  1138.  
  1139.          end if;
  1140.  
  1141.          --  Print Do_Overflow_Check field if present
  1142.  
  1143.          if Nkind (N) in N_Op and then Do_Overflow_Check (N) then
  1144.             Print_Str (Prefix_Str_Char);
  1145.             Print_Str ("Do_Overflow_Check = True");
  1146.             Print_Eol;
  1147.          end if;
  1148.  
  1149.          --  Print Etype field if present (printing of this field for entities
  1150.          --  is handled by the Print_Entity_Info procedure).
  1151.  
  1152.          if Nkind (N) in N_Has_Etype
  1153.            and then Present (Etype (N))
  1154.          then
  1155.             Print_Str (Prefix_Str_Char);
  1156.             Print_Str ("Etype = ");
  1157.             Print_Node_Ref (Etype (N));
  1158.             Print_Eol;
  1159.          end if;
  1160.       end if;
  1161.  
  1162.       --  Loop to print fields included in Pchars array
  1163.  
  1164.       while P < Pchar_Pos (Node_Kind'Succ (Nkind (N))) loop
  1165.          F := Pchars (P);
  1166.          P := P + 1;
  1167.  
  1168.          --  Check for case of False flag, which we never print, or
  1169.          --  an Empty field, which is also never printed
  1170.  
  1171.          case F is
  1172.             when F_Field1 =>
  1173.                Field_To_Be_Printed := Field1 (N) /= Union_Id (Empty);
  1174.  
  1175.             when F_Field2 =>
  1176.                Field_To_Be_Printed := Field2 (N) /= Union_Id (Empty);
  1177.  
  1178.             when F_Field3 =>
  1179.                Field_To_Be_Printed := Field3 (N) /= Union_Id (Empty);
  1180.  
  1181.             when F_Field4 =>
  1182.                Field_To_Be_Printed := Field4 (N) /= Union_Id (Empty);
  1183.  
  1184.             when F_Field5 =>
  1185.                Field_To_Be_Printed := Field5 (N) /= Union_Id (Empty);
  1186.  
  1187.             when F_Flag1  => Field_To_Be_Printed := Flag1  (N);
  1188.             when F_Flag3  => Field_To_Be_Printed := Flag3  (N);
  1189.             when F_Flag4  => Field_To_Be_Printed := Flag4  (N);
  1190.             when F_Flag5  => Field_To_Be_Printed := Flag5  (N);
  1191.             when F_Flag6  => Field_To_Be_Printed := Flag6  (N);
  1192.             when F_Flag7  => Field_To_Be_Printed := Flag7  (N);
  1193.             when F_Flag8  => Field_To_Be_Printed := Flag8  (N);
  1194.             when F_Flag9  => Field_To_Be_Printed := Flag9  (N);
  1195.             when F_Flag10 => Field_To_Be_Printed := Flag10 (N);
  1196.             when F_Flag11 => Field_To_Be_Printed := Flag11 (N);
  1197.             when F_Flag12 => Field_To_Be_Printed := Flag12 (N);
  1198.             when F_Flag13 => Field_To_Be_Printed := Flag13 (N);
  1199.             when F_Flag14 => Field_To_Be_Printed := Flag14 (N);
  1200.             when F_Flag15 => Field_To_Be_Printed := Flag15 (N);
  1201.             when F_Flag16 => Field_To_Be_Printed := Flag16 (N);
  1202.             when F_Flag17 => Field_To_Be_Printed := Flag17 (N);
  1203.             when F_Flag18 => Field_To_Be_Printed := Flag18 (N);
  1204.  
  1205.             --  Flag2 is no longer used, it is now used for Comes_From_Source
  1206.  
  1207.             when F_Flag2  => pragma Assert (False); null;
  1208.  
  1209.          end case;
  1210.  
  1211.          --  Print field if it is to be printed
  1212.  
  1213.          if Field_To_Be_Printed then
  1214.             Print_Str (Prefix_Str_Char);
  1215.  
  1216.             while P < Pchar_Pos (Node_Kind'Succ (Nkind (N)))
  1217.               and then Pchars (P) not in Fchar
  1218.             loop
  1219.                Print_Char (Pchars (P));
  1220.                P := P + 1;
  1221.             end loop;
  1222.  
  1223.             Print_Str (" = ");
  1224.  
  1225.             case F is
  1226.                when F_Field1 => Print_Field (Field1 (N));
  1227.                when F_Field2 => Print_Field (Field2 (N));
  1228.                when F_Field3 => Print_Field (Field3 (N));
  1229.                when F_Field4 => Print_Field (Field4 (N));
  1230.                when F_Field5 => Print_Field (Field5 (N));
  1231.  
  1232.                when F_Flag1  => Print_Flag  (Flag1 (N));
  1233.                when F_Flag3  => Print_Flag  (Flag3 (N));
  1234.                when F_Flag4  => Print_Flag  (Flag4 (N));
  1235.                when F_Flag5  => Print_Flag  (Flag5 (N));
  1236.                when F_Flag6  => Print_Flag  (Flag6 (N));
  1237.                when F_Flag7  => Print_Flag  (Flag7 (N));
  1238.                when F_Flag8  => Print_Flag  (Flag8 (N));
  1239.                when F_Flag9  => Print_Flag  (Flag9 (N));
  1240.                when F_Flag10 => Print_Flag  (Flag10 (N));
  1241.                when F_Flag11 => Print_Flag  (Flag11 (N));
  1242.                when F_Flag12 => Print_Flag  (Flag12 (N));
  1243.                when F_Flag13 => Print_Flag  (Flag13 (N));
  1244.                when F_Flag14 => Print_Flag  (Flag14 (N));
  1245.                when F_Flag15 => Print_Flag  (Flag15 (N));
  1246.                when F_Flag16 => Print_Flag  (Flag16 (N));
  1247.                when F_Flag17 => Print_Flag  (Flag17 (N));
  1248.                when F_Flag18 => Print_Flag  (Flag18 (N));
  1249.  
  1250.                --  Flag2 is no longer used (now used for Comes_From_Source)
  1251.  
  1252.                when F_Flag2  => pragma Assert (False); null;
  1253.             end case;
  1254.  
  1255.             Print_Eol;
  1256.  
  1257.          --  Field is not to be printed (False flag field)
  1258.  
  1259.          else
  1260.             while P < Pchar_Pos (Node_Kind'Succ (Nkind (N)))
  1261.               and then Pchars (P) not in Fchar
  1262.             loop
  1263.                P := P + 1;
  1264.             end loop;
  1265.          end if;
  1266.  
  1267.       end loop;
  1268.  
  1269.       --  Print entity information for entities
  1270.  
  1271.       if Nkind (N) in N_Entity then
  1272.          Print_Entity_Info (N, Prefix_Str_Char);
  1273.       end if;
  1274.  
  1275.    end Print_Node;
  1276.  
  1277.    -------------------
  1278.    -- Serial_Number --
  1279.    -------------------
  1280.  
  1281.    --  The hashing algorithm is to use the remainder of the ID value divided
  1282.    --  by the hash table length as the starting point in the table, and then
  1283.    --  handle collisions by serial searching wrapping at the end of the table.
  1284.  
  1285.    Hash_Slot : Nat;
  1286.    --  Set by an unsuccessful call to Serial_Number (one which returns zero)
  1287.    --  to save the slot that should be used if Set_Serial_Number is called.
  1288.  
  1289.    function Serial_Number (Id : Int) return Nat is
  1290.       H : Int := Id mod Hash_Table_Len;
  1291.  
  1292.    begin
  1293.       while Hash_Table (H).Serial /= 0 loop
  1294.  
  1295.          if Id = Hash_Table (H).Id then
  1296.             return Hash_Table (H).Serial;
  1297.          end if;
  1298.  
  1299.          H := H + 1;
  1300.  
  1301.          if H > Hash_Table'Last then
  1302.             H := 0;
  1303.          end if;
  1304.       end loop;
  1305.  
  1306.       --  Entry was not found, save slot number for possible subsequent call
  1307.       --  to Set_Serial_Number, and unconditionally save the Id in this slot
  1308.       --  in case of such a call (the Id field is never read if the serial
  1309.       --  number of the slot is zero, so this is harmless in the case where
  1310.       --  Set_Serial_Number is not subsequently called).
  1311.  
  1312.       Hash_Slot := H;
  1313.       Hash_Table (H).Id := Id;
  1314.       return 0;
  1315.  
  1316.    end Serial_Number;
  1317.  
  1318.    -----------------------
  1319.    -- Set_Serial_Number --
  1320.    -----------------------
  1321.  
  1322.    procedure Set_Serial_Number is
  1323.    begin
  1324.       Hash_Table (Hash_Slot).Serial := Next_Serial_Number;
  1325.       Next_Serial_Number := Next_Serial_Number + 1;
  1326.    end Set_Serial_Number;
  1327.  
  1328.    ----------------
  1329.    -- Visit_Node --
  1330.    ----------------
  1331.  
  1332.    procedure Visit_Node
  1333.      (N           : Node_Id;
  1334.       Prefix_Str  : String;
  1335.       Prefix_Char : Character)
  1336.    is
  1337.       New_Prefix : String (Prefix_Str'First .. Prefix_Str'Last + 2);
  1338.       --  Prefix string for printing referenced fields
  1339.  
  1340.       procedure Visit_Descendent (D : Union_Id);
  1341.       --  This procedure tests the given value of one of the Fields referenced
  1342.       --  by the current node to determine whether to visit it recursively.
  1343.  
  1344.       procedure Visit_Descendent (D : Union_Id) is
  1345.       begin
  1346.          --  Case of descendent is a node
  1347.  
  1348.          if D in Node_Range then
  1349.             --  Don't bother about Empty or Error descendents
  1350.  
  1351.             if D <= Union_Id (Empty_Or_Error) then
  1352.                return;
  1353.             end if;
  1354.  
  1355.             --  Descendents in one of the standardly compiled internal
  1356.             --  packages are normally ignored, unless the parent is also
  1357.             --  in such a package (happens when Standard itself is output)
  1358.             --  or if the -df switch is set which causes all links to be
  1359.             --  followed, even into package standard.
  1360.  
  1361.             if Sloc (Node_Id (D)) <= Standard_Location then
  1362.                if Sloc (N) > Standard_Location
  1363.                  and then not Debug_Flag_F
  1364.                then
  1365.                   return;
  1366.                end if;
  1367.  
  1368.             --  Don't bother about a descendent in a different unit than
  1369.             --  the node we came from unless the -df switch is set. Note
  1370.             --  that we know at this point that Sloc (D) > Standard_Location
  1371.  
  1372.             --  Note: the tests for No_Location here just make sure that we
  1373.             --  don't blow up on a node which is missing an Sloc value. This
  1374.             --  should not normally happen.
  1375.  
  1376.             else
  1377.                if (Sloc (N) <= Standard_Location
  1378.                      or else Sloc (N) = No_Location
  1379.                      or else Sloc (Node_Id (D)) = No_Location
  1380.                      or else Get_Sloc_Unit_Number (Sloc (Node_Id (D))) /=
  1381.                              Get_Sloc_Unit_Number (Sloc (N)))
  1382.                  and then not Debug_Flag_F
  1383.                then
  1384.                   return;
  1385.                end if;
  1386.             end if;
  1387.  
  1388.             --  Don't bother visiting a node that has a parent, but the parent
  1389.             --  isn't the node we came from. We prefer to trace such nodes
  1390.             --  from their real parents. This causes the tree to be printed
  1391.             --  in a more coherent order, e.g. a defining identifier listed
  1392.             --  next to its corresponding declaration, instead of next to
  1393.             --  some semantic reference.
  1394.  
  1395.             --  This test is skipped for nodes in standard packages unless
  1396.             --  the -dy option is set (which outputs the tree for standard)
  1397.  
  1398.             if Parent (Node_Id (D)) /= Empty
  1399.               and then Parent (Node_Id (D)) /= N
  1400.               and then (Sloc (N) > Standard_Location or else Debug_Flag_Y)
  1401.             then
  1402.                return;
  1403.             end if;
  1404.  
  1405.             --  If we successfully fall through all the above tests (which
  1406.             --  execute a return if the node is not to be visited), we can
  1407.             --  go ahead and visit the node!
  1408.  
  1409.             Visit_Node (Node_Id (D), New_Prefix, ' ');
  1410.  
  1411.          --  Case of descendent is a list
  1412.  
  1413.          elsif D in List_Range then
  1414.  
  1415.             --  Don't bother with a missing list, empty list or error list
  1416.  
  1417.             if D = Union_Id (No_List)
  1418.               or else D = Union_Id (Error_List)
  1419.               or else Is_Empty_List (List_Id (D))
  1420.             then
  1421.                return;
  1422.  
  1423.             --  Otherwise we can visit the list. Note that we don't bother
  1424.             --  to do the parent test that we did for the node case, because
  1425.             --  it just does not happen that lists are referenced more than
  1426.             --  one place in the tree. We aren't counting on this being the
  1427.             --  case to generate valid output, it is just that we don't need
  1428.             --  in practice to worry about listing the list at a place that
  1429.             --  is inconvenient.
  1430.  
  1431.             else
  1432.                Visit_List (List_Id (D), New_Prefix);
  1433.             end if;
  1434.  
  1435.          --  Case of descendent is an element list
  1436.  
  1437.          elsif D in Elist_Range then
  1438.  
  1439.             --  Don't bother with a missing list, or an empty list
  1440.  
  1441.             if D = Union_Id (No_Elist)
  1442.               or else Is_Empty_Elmt_List (Elist_Id (D))
  1443.             then
  1444.                return;
  1445.  
  1446.             --  Otherwise, visit the referenced element list
  1447.  
  1448.             else
  1449.                Visit_Elist (Elist_Id (D), New_Prefix);
  1450.             end if;
  1451.  
  1452.          --  For all other kinds of descendents (strings, names, uints etc),
  1453.          --  there is nothing to visit (the contents of the field will be
  1454.          --  printed when we print the containing node, but what concerns
  1455.          --  us now is looking for descendents in the tree.
  1456.  
  1457.          else
  1458.             null;
  1459.          end if;
  1460.       end Visit_Descendent;
  1461.  
  1462.    --  Start of processing for Visit_Node
  1463.  
  1464.    begin
  1465.       if N = Empty then
  1466.          return;
  1467.       end if;
  1468.  
  1469.       --  Set fatal error node in case we get a blow up during the trace
  1470.  
  1471.       Fatal_Error_Node := N;
  1472.  
  1473.       New_Prefix (Prefix_Str'Range)    := Prefix_Str;
  1474.       New_Prefix (Prefix_Str'Last + 1) := Prefix_Char;
  1475.       New_Prefix (Prefix_Str'Last + 2) := ' ';
  1476.  
  1477.       --  In the marking phase, all we do is to set the serial number
  1478.  
  1479.       if Phase = Marking then
  1480.          if Serial_Number (Int (N)) /= 0 then
  1481.             return; -- already visited
  1482.          else
  1483.             Set_Serial_Number;
  1484.          end if;
  1485.  
  1486.       --  In the printing phase, we print the node
  1487.  
  1488.       else
  1489.          if Serial_Number (Int (N)) < Next_Serial_Number then
  1490.             return; -- already printed
  1491.          else
  1492.             Print_Node (N, Prefix_Str, Prefix_Char);
  1493.             Print_Str (Prefix_Str);
  1494.             Print_Char (Prefix_Char);
  1495.             Print_Eol;
  1496.             Next_Serial_Number := Next_Serial_Number + 1;
  1497.          end if;
  1498.       end if;
  1499.  
  1500.       --  Visit all descendents of this node
  1501.  
  1502.       Visit_Descendent (Field1 (N));
  1503.       Visit_Descendent (Field2 (N));
  1504.       Visit_Descendent (Field3 (N));
  1505.       Visit_Descendent (Field4 (N));
  1506.       Visit_Descendent (Field5 (N));
  1507.  
  1508.       if Nkind (N) in N_Entity then
  1509.          Visit_Descendent (Field6 (N));
  1510.          Visit_Descendent (Field7 (N));
  1511.          Visit_Descendent (Field8 (N));
  1512.          Visit_Descendent (Field9 (N));
  1513.          Visit_Descendent (Field10 (N));
  1514.          Visit_Descendent (Field11 (N));
  1515.          Visit_Descendent (Field12 (N));
  1516.          Visit_Descendent (Field13 (N));
  1517.          Visit_Descendent (Field14 (N));
  1518.          Visit_Descendent (Field15 (N));
  1519.          Visit_Descendent (Field16 (N));
  1520.          Visit_Descendent (Field17 (N));
  1521.          Visit_Descendent (Field18 (N));
  1522.          Visit_Descendent (Field19 (N));
  1523.          Visit_Descendent (Field20 (N));
  1524.          Visit_Descendent (Field21 (N));
  1525.          Visit_Descendent (Field22 (N));
  1526.       end if;
  1527.    end Visit_Node;
  1528.  
  1529.    ----------------
  1530.    -- Visit_List --
  1531.    ----------------
  1532.  
  1533.    procedure Visit_List (L : List_Id; Prefix_Str : String) is
  1534.       N : Node_Id;
  1535.       S : constant Nat := Serial_Number (Int (L));
  1536.  
  1537.    begin
  1538.       --  In marking phase, return if already marked, otherwise set next
  1539.       --  serial number in hash table for later reference.
  1540.  
  1541.       if Phase = Marking then
  1542.          if S /= 0 then
  1543.             return;
  1544.          else
  1545.             Set_Serial_Number;
  1546.          end if;
  1547.  
  1548.       --  In printing phase, if already printed, then return, otherwise we
  1549.       --  are printing the next item, so increment the serial number.
  1550.  
  1551.       else
  1552.          if S < Next_Serial_Number then
  1553.             return; -- already printed
  1554.          else
  1555.             Next_Serial_Number := Next_Serial_Number + 1;
  1556.          end if;
  1557.       end if;
  1558.  
  1559.       --  Now process the list (Print calls have no effect in marking phase)
  1560.  
  1561.       Print_Str (Prefix_Str);
  1562.       Print_List_Ref (L);
  1563.       Print_Eol;
  1564.  
  1565.       Print_Str (Prefix_Str);
  1566.       Print_Str ("|Parent = ");
  1567.       Print_Node_Ref (Parent (L));
  1568.       Print_Eol;
  1569.  
  1570.       N := First (L);
  1571.  
  1572.       if N = Empty then
  1573.          Print_Str (Prefix_Str);
  1574.          Print_Str ("(Empty list)");
  1575.          Print_Eol;
  1576.          Print_Eol;
  1577.  
  1578.       else
  1579.          Print_Str (Prefix_Str);
  1580.          Print_Char ('|');
  1581.          Print_Eol;
  1582.  
  1583.          while Next (N) /= Empty loop
  1584.             Visit_Node (N, Prefix_Str, '|');
  1585.             N := Next (N);
  1586.          end loop;
  1587.       end if;
  1588.  
  1589.       Visit_Node (N, Prefix_Str, ' ');
  1590.    end Visit_List;
  1591.  
  1592.    -----------------
  1593.    -- Visit_Elist --
  1594.    -----------------
  1595.  
  1596.    procedure Visit_Elist (E : Elist_Id; Prefix_Str : String) is
  1597.       M : Elmt_Id;
  1598.       N : Node_Id;
  1599.       S : constant Nat := Serial_Number (Int (E));
  1600.  
  1601.    begin
  1602.       --  In marking phase, return if already marked, otherwise set next
  1603.       --  serial number in hash table for later reference.
  1604.  
  1605.       if Phase = Marking then
  1606.          if S /= 0 then
  1607.             return; -- already visited
  1608.          else
  1609.             Set_Serial_Number;
  1610.          end if;
  1611.  
  1612.       --  In printing phase, if already printed, then return, otherwise we
  1613.       --  are printing the next item, so increment the serial number.
  1614.  
  1615.       else
  1616.          if S < Next_Serial_Number then
  1617.             return; -- already printed
  1618.          else
  1619.             Next_Serial_Number := Next_Serial_Number + 1;
  1620.          end if;
  1621.       end if;
  1622.  
  1623.       --  Now process the list (Print calls have no effect in marking phase)
  1624.  
  1625.       Print_Str (Prefix_Str);
  1626.       Print_Elist_Ref (E);
  1627.       Print_Eol;
  1628.  
  1629.       if Is_Empty_Elmt_List (E) then
  1630.          Print_Str (Prefix_Str);
  1631.          Print_Str ("(Empty element list)");
  1632.          Print_Eol;
  1633.          Print_Eol;
  1634.  
  1635.       else
  1636.          if Phase = Printing then
  1637.             M := First_Elmt (E);
  1638.             while Present (M) loop
  1639.                N := Node (M);
  1640.                Print_Str (Prefix_Str);
  1641.                Print_Str (" ");
  1642.                Print_Node_Ref (N);
  1643.                Print_Eol;
  1644.                M := Next_Elmt (M);
  1645.             end loop;
  1646.  
  1647.             Print_Str (Prefix_Str);
  1648.             Print_Eol;
  1649.          end if;
  1650.  
  1651.          M := First_Elmt (E);
  1652.          while Present (M) loop
  1653.             Visit_Node (Node (M), Prefix_Str, ' ');
  1654.             M := Next_Elmt (M);
  1655.          end loop;
  1656.       end if;
  1657.    end Visit_Elist;
  1658.  
  1659.    --------------------------
  1660.    -- Debugging procedures --
  1661.    --------------------------
  1662.  
  1663.    procedure PN (N : Node_Id) is
  1664.    begin
  1665.       Print_Tree_Node (N);
  1666.    end PN;
  1667.  
  1668.    procedure PT (N : Node_Id) is
  1669.    begin
  1670.       Print_Node_Subtree (N);
  1671.    end PT;
  1672.  
  1673.  
  1674. end Treepr;
  1675.