projects / thirdparty / gcc.git / blame
| Commit | Line | Data |
|---|---|---|
| 70482933 RK |
1 | ------------------------------------------------------------------------------ |
| 2 | -- -- | |
| 3 | -- GNAT COMPILER COMPONENTS -- | |
| 4 | -- -- | |
| 5 | -- D E B U G _ A -- | |
| 6 | -- -- | |
| 7 | -- B o d y -- | |
| 8 | -- -- | |
| 70482933 RK |
9 | -- -- |
| 10 | -- Copyright (C) 1992-1998 Free Software Foundation, Inc. -- | |
| 11 | -- -- | |
| 12 | -- GNAT is free software; you can redistribute it and/or modify it under -- | |
| 13 | -- terms of the GNU General Public License as published by the Free Soft- -- | |
| 14 | -- ware Foundation; either version 2, or (at your option) any later ver- -- | |
| 15 | -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- | |
| 16 | -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- | |
| 17 | -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- | |
| 18 | -- for more details. You should have received a copy of the GNU General -- | |
| 19 | -- Public License distributed with GNAT; see file COPYING. If not, write -- | |
| 20 | -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, -- | |
| 21 | -- MA 02111-1307, USA. -- | |
| 22 | -- -- | |
| 23 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
| 24 | -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). -- | |
| 25 | -- -- | |
| 26 | ------------------------------------------------------------------------------ | |
| 27 | ||
| 28 | with Atree; use Atree; | |
| 29 | with Debug; use Debug; | |
| 30 | with Sinfo; use Sinfo; | |
| 31 | with Sinput; use Sinput; | |
| 32 | with Output; use Output; | |
| 33 | ||
| 34 | package body Debug_A is | |
| 35 | ||
| 36 | Debug_A_Depth : Natural := 0; | |
| 37 | -- Output for the debug A flag is preceded by a sequence of vertical bar | |
| 38 | -- characters corresponding to the recursion depth of the actions being | |
| 39 | -- recorded (analysis, expansion, resolution and evaluation of nodes) | |
| 40 | -- This variable records the depth. | |
| 41 | ||
| 42 | Max_Node_Ids : constant := 200; | |
| 43 | -- Maximum number of Node_Id values that get stacked | |
| 44 | ||
| 45 | Node_Ids : array (1 .. Max_Node_Ids) of Node_Id; | |
| 46 | -- A stack used to keep track of Node_Id values for setting the value of | |
| 47 | -- Current_Error_Node correctly. Note that if we have more than 200 | |
| 48 | -- recursion levels, we just don't reset the right value on exit, which | |
| 49 | -- is not crucial, since this is only for debugging! | |
| 50 | ||
| 51 | ----------------------- | |
| 52 | -- Local Subprograms -- | |
| 53 | ----------------------- | |
| 54 | ||
| 55 | procedure Debug_Output_Astring; | |
| 56 | -- Outputs Debug_A_Depth number of vertical bars, used to preface messages | |
| 57 | ||
| 58 | ------------------- | |
| 59 | -- Debug_A_Entry -- | |
| 60 | ------------------- | |
| 61 | ||
| 62 | procedure Debug_A_Entry (S : String; N : Node_Id) is | |
| 63 | begin | |
| 64 | if Debug_Flag_A then | |
| 65 | Debug_Output_Astring; | |
| 66 | Write_Str (S); | |
| 67 | Write_Str ("Node_Id = "); | |
| 68 | Write_Int (Int (N)); | |
| 69 | Write_Str (" "); | |
| 70 | Write_Location (Sloc (N)); | |
| 71 | Write_Str (" "); | |
| 72 | Write_Str (Node_Kind'Image (Nkind (N))); | |
| 73 | Write_Eol; | |
| 74 | end if; | |
| 75 | ||
| 76 | Debug_A_Depth := Debug_A_Depth + 1; | |
| 77 | Current_Error_Node := N; | |
| 78 | ||
| 79 | if Debug_A_Depth <= Max_Node_Ids then | |
| 80 | Node_Ids (Debug_A_Depth) := N; | |
| 81 | end if; | |
| 82 | end Debug_A_Entry; | |
| 83 | ||
| 84 | ------------------ | |
| 85 | -- Debug_A_Exit -- | |
| 86 | ------------------ | |
| 87 | ||
| 88 | procedure Debug_A_Exit (S : String; N : Node_Id; Comment : String) is | |
| 89 | begin | |
| 90 | Debug_A_Depth := Debug_A_Depth - 1; | |
| 91 | ||
| 92 | if Debug_A_Depth in 1 .. Max_Node_Ids then | |
| 93 | Current_Error_Node := Node_Ids (Debug_A_Depth); | |
| 94 | end if; | |
| 95 | ||
| 96 | if Debug_Flag_A then | |
| 97 | Debug_Output_Astring; | |
| 98 | Write_Str (S); | |
| 99 | Write_Str ("Node_Id = "); | |
| 100 | Write_Int (Int (N)); | |
| 101 | Write_Str (Comment); | |
| 102 | Write_Eol; | |
| 103 | end if; | |
| 104 | end Debug_A_Exit; | |
| 105 | ||
| 106 | -------------------------- | |
| 107 | -- Debug_Output_Astring -- | |
| 108 | -------------------------- | |
| 109 | ||
| 110 | procedure Debug_Output_Astring is | |
| 111 | Vbars : String := "|||||||||||||||||||||||||"; | |
| 112 | -- Should be constant, removed because of GNAT 1.78 bug ??? | |
| 113 | ||
| 114 | begin | |
| 115 | if Debug_A_Depth > Vbars'Length then | |
| 116 | for I in Vbars'Length .. Debug_A_Depth loop | |
| 117 | Write_Char ('|'); | |
| 118 | end loop; | |
| 119 | ||
| 120 | Write_Str (Vbars); | |
| 121 | ||
| 122 | else | |
| 123 | Write_Str (Vbars (1 .. Debug_A_Depth)); | |
| 124 | end if; | |
| 125 | end Debug_Output_Astring; | |
| 126 | ||
| 127 | end Debug_A; |