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 / debug_a.adb < prev    next >
Text File  |  1996-09-28  |  5KB  |  125 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                              D E B U G _ A                               --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.8 $                              --
  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 Debug;  use Debug;
  27. with Sinfo;  use Sinfo;
  28. with Sinput; use Sinput;
  29. with Output; use Output;
  30.  
  31. package body Debug_A is
  32.  
  33.    Debug_A_Depth : Natural := 0;
  34.    --  Output for the debug A flag is preceded by a sequence of vertical bar
  35.    --  characters corresponding to the recursion depth of the actions being
  36.    --  recorded (analysis, expansion, resolution and evaluation of nodes)
  37.    --  This variable records the depth.
  38.  
  39.    Max_Node_Ids : constant := 200;
  40.    --  Maximum number of Node_Id values that get stacked
  41.  
  42.    Node_Ids : array (1 .. Max_Node_Ids) of Node_Id;
  43.    --  A stack used to keep track of Node_Id values for setting the value of
  44.    --  Fatal_Error_Node correctly. Note that if we have more than 100 recursion
  45.    --  levels, we just don't reset the right value on exit, which is not
  46.    --  crucial, since this is only for debugging!
  47.  
  48.    -----------------------
  49.    -- Local Subprograms --
  50.    -----------------------
  51.  
  52.    procedure Debug_Output_Astring;
  53.    --  Outputs Debug_A_Depth number of vertical bars, used to preface messages
  54.  
  55.    -------------------
  56.    -- Debug_A_Entry --
  57.    -------------------
  58.  
  59.    procedure Debug_A_Entry (S : String; N : Node_Id) is
  60.    begin
  61.       if Debug_Flag_A then
  62.          Debug_Output_Astring;
  63.          Write_Str (S);
  64.          Write_Str ("Node_Id = ");
  65.          Write_Int (Int (N));
  66.          Write_Str ("  ");
  67.          Write_Location (Sloc (N));
  68.          Write_Str ("  ");
  69.          Write_Str (Node_Kind'Image (Nkind (N)));
  70.          Write_Eol;
  71.       end if;
  72.  
  73.       Debug_A_Depth := Debug_A_Depth + 1;
  74.       Fatal_Error_Node := N;
  75.  
  76.       if Debug_A_Depth <= Max_Node_Ids then
  77.          Node_Ids (Debug_A_Depth) := N;
  78.       end if;
  79.    end Debug_A_Entry;
  80.  
  81.    ------------------
  82.    -- Debug_A_Exit --
  83.    ------------------
  84.  
  85.    procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String) is
  86.    begin
  87.       Debug_A_Depth := Debug_A_Depth - 1;
  88.  
  89.       if Debug_A_Depth in 1 .. Max_Node_Ids then
  90.          Fatal_Error_Node := Node_Ids (Debug_A_Depth);
  91.       end if;
  92.  
  93.       if Debug_Flag_A then
  94.          Debug_Output_Astring;
  95.          Write_Str (S);
  96.          Write_Str ("Node_Id = ");
  97.          Write_Int (Int (N));
  98.          Write_Str (Comment);
  99.          Write_Eol;
  100.       end if;
  101.    end Debug_A_Exit;
  102.  
  103.    --------------------------
  104.    -- Debug_Output_Astring --
  105.    --------------------------
  106.  
  107.    procedure Debug_Output_Astring is
  108.       Vbars : String := "|||||||||||||||||||||||||";
  109.       --  Should be constant, removed because of GNAT 1.78 bug ???
  110.  
  111.    begin
  112.       if Debug_A_Depth > Vbars'Length then
  113.          for I in Vbars'Length .. Debug_A_Depth loop
  114.             Write_Char ('|');
  115.          end loop;
  116.  
  117.          Write_Str (Vbars);
  118.  
  119.       else
  120.          Write_Str (Vbars (1 .. Debug_A_Depth));
  121.       end if;
  122.    end Debug_Output_Astring;
  123.  
  124. end Debug_A;
  125.