1--  PSL - Disp nodes
2--  Copyright (C) 2002-2016 Tristan Gingold
3--
4--  This program is free software: you can redistribute it and/or modify
5--  it under the terms of the GNU General Public License as published by
6--  the Free Software Foundation, either version 2 of the License, or
7--  (at your option) any later version.
8--
9--  This program is distributed in the hope that it will be useful,
10--  but WITHOUT ANY WARRANTY; without even the implied warranty of
11--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12--  GNU General Public License for more details.
13--
14--  You should have received a copy of the GNU General Public License
15--  along with this program.  If not, see <gnu.org/licenses>.
16
17with Ada.Text_IO; use Ada.Text_IO;
18with Types; use Types;
19with Name_Table;
20with PSL.Types; use PSL.Types;
21with PSL.Errors;
22with PSL.Nodes_Meta;
23
24package body PSL.Dump_Tree is
25
26   procedure Put_Indent (Indent : Natural) is
27   begin
28      Put (String'(1 .. 2 * Indent => ' '));
29   end Put_Indent;
30
31   Hex_Digits : constant array (Integer range 0 .. 15) of Character
32     := "0123456789abcdef";
33
34   procedure Disp_Uns32 (Val : Uns32)
35   is
36      Res : String (1 .. 8);
37      V : Uns32 := Val;
38   begin
39      for I in reverse Res'Range loop
40         Res (I) := Hex_Digits (Integer (V mod 16));
41         V := V / 16;
42      end loop;
43      Put (Res);
44   end Disp_Uns32;
45
46   procedure Disp_Int32 (Val : Int32)
47   is
48      Res : String (1 .. 8);
49      V : Int32 := Val;
50   begin
51      for I in reverse Res'Range loop
52         Res (I) := Hex_Digits (Integer (V mod 16));
53         V := V / 16;
54      end loop;
55      Put (Res);
56   end Disp_Int32;
57
58   function Image_Boolean (Bool : Boolean) return String is
59   begin
60      if Bool then
61         return "true";
62      else
63         return "false";
64      end if;
65   end Image_Boolean;
66
67   procedure Disp_HDL_Node
68     (Val : HDL_Node; Indent : Natural; Depth : Natural) is
69   begin
70      if Dump_Hdl_Node /= null then
71         Dump_Hdl_Node.all (Val, Indent, Depth);
72      else
73         Disp_Int32 (Val);
74         New_Line;
75      end if;
76   end Disp_HDL_Node;
77
78   procedure Disp_Node_Number (N : Node) is
79   begin
80      Put ('[');
81      Disp_Int32 (Int32 (N));
82      Put (']');
83   end Disp_Node_Number;
84
85   procedure Disp_NFA (Val : NFA) is
86   begin
87      Disp_Int32 (Int32 (Val));
88   end Disp_NFA;
89
90   procedure Disp_Header (Msg : String; Indent : Natural) is
91   begin
92      Put_Indent (Indent);
93      Put (Msg);
94      Put (": ");
95   end Disp_Header;
96
97   function Image_PSL_Presence_Kind (Pres : PSL_Presence_Kind) return String
98   is
99   begin
100      case Pres is
101         when Present_Pos =>
102            return "+";
103         when Present_Neg =>
104            return "-";
105         when Present_Unknown =>
106            return "?";
107      end case;
108   end Image_PSL_Presence_Kind;
109
110   procedure Disp_Location (Loc : Location_Type) is
111   begin
112      Put (PSL.Errors.Image (Loc));
113   end Disp_Location;
114
115--     procedure Disp_String_Id (N : Node) is
116--     begin
117--        Put ('"');
118--        Put (Str_Table.Image (Get_String_Id (N)));
119--        Put ('"');
120--        New_Line;
121--     end Disp_String_Id;
122
123   procedure Disp_Header (N : Node)
124   is
125      use Nodes_Meta;
126      K : Nkind;
127   begin
128      if N = Null_Node then
129         Put_Line ("*null*");
130         return;
131      end if;
132
133      K := Get_Kind (N);
134      Put (Get_Nkind_Image (K));
135      if Has_Identifier (K) then
136         Put (' ');
137         Put (Name_Table.Image (Get_Identifier (N)));
138      end if;
139
140      Put (' ');
141      Disp_Node_Number (N);
142
143      New_Line;
144   end Disp_Header;
145
146   procedure Disp_Chain (Tree_Chain: Node; Indent: Natural; Depth : Natural)
147   is
148      El: Node;
149   begin
150      New_Line;
151      El := Tree_Chain;
152      while El /= Null_Node loop
153         Put_Indent (Indent);
154         Disp_Tree (El, Indent + 1, Depth);
155         El := Get_Chain (El);
156      end loop;
157   end Disp_Chain;
158
159   procedure Disp_Tree (N : Node; Indent : Natural; Depth : Natural) is
160   begin
161      Disp_Header (N);
162
163      if Depth <= 1 or else N = Null_Node then
164         return;
165      end if;
166
167      Disp_Header ("location", Indent);
168      Disp_Location (Get_Location (N));
169      New_Line;
170
171      declare
172         use Nodes_Meta;
173         Sub_Indent : constant Natural := Indent + 1;
174
175         Fields : constant Fields_Array := Get_Fields (Get_Kind (N));
176         F : Fields_Enum;
177      begin
178         for I in Fields'Range loop
179            F := Fields (I);
180            Disp_Header (Get_Field_Image (F), Indent);
181            case Get_Field_Type (F) is
182               when Type_Node =>
183                  case Get_Field_Attribute (F) is
184                     when Attr_None =>
185                        Disp_Tree (Get_Node (N, F), Sub_Indent, Depth - 1);
186                     when Attr_Ref =>
187                        Disp_Tree (Get_Node (N, F), Sub_Indent, 0);
188                     when Attr_Chain =>
189                        Disp_Chain (Get_Node (N, F), Sub_Indent, Depth - 1);
190                     when Attr_Chain_Next =>
191                        Disp_Node_Number (Get_Node (N, F));
192                        New_Line;
193                     when Attr_Maybe_Ref | Attr_Of_Ref =>
194                        raise Internal_Error;
195                  end case;
196               when Type_Boolean =>
197                  Put_Line (Image_Boolean (Get_Boolean (N, F)));
198               when Type_Int32 =>
199                  Disp_Int32 (Get_Int32 (N, F));
200                  New_Line;
201               when Type_Uns32 =>
202                  Disp_Uns32 (Get_Uns32 (N, F));
203                  New_Line;
204               when Type_Name_Id =>
205                  Put_Line (Name_Table.Image (Get_Name_Id (N, F)));
206               when Type_HDL_Node =>
207                  Disp_HDL_Node (Get_HDL_Node (N, F), Sub_Indent, Depth - 1);
208               when Type_NFA =>
209                  Disp_NFA (Get_NFA (N, F));
210                  New_Line;
211               when Type_PSL_Presence_Kind =>
212                  Put (Image_PSL_Presence_Kind (Get_PSL_Presence_Kind (N, F)));
213                  New_Line;
214            end case;
215         end loop;
216      end;
217   end Disp_Tree;
218
219end PSL.Dump_Tree;
220