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