1-- PSL - Printer 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 Types; use Types; 18with PSL.Errors; use PSL.Errors; 19with PSL.Prints; 20with Ada.Text_IO; use Ada.Text_IO; 21with Name_Table; use Name_Table; 22 23package body PSL.Tprint is 24 procedure Disp_Expr (N : Node) is 25 begin 26 case Get_Kind (N) is 27 when N_Number => 28 declare 29 Str : constant String := Uns32'Image (Get_Value (N)); 30 begin 31 Put (Str (2 .. Str'Last)); 32 end; 33 when others => 34 Error_Kind ("disp_expr", N); 35 end case; 36 end Disp_Expr; 37 38 procedure Disp_Count (N : Node) is 39 B : Node; 40 begin 41 B := Get_Low_Bound (N); 42 if B = Null_Node then 43 return; 44 end if; 45 Disp_Expr (B); 46 B := Get_High_Bound (N); 47 if B = Null_Node then 48 return; 49 end if; 50 Put (":"); 51 Disp_Expr (B); 52 end Disp_Count; 53 54 procedure Put_Node (Prefix : String; Name : String) is 55 begin 56 Put (Prefix); 57 Put ("-+ "); 58 Put (Name); 59 end Put_Node; 60 61 procedure Put_Node_Line (Prefix : String; Name : String) is 62 begin 63 Put_Node (Prefix, Name); 64 New_Line; 65 end Put_Node_Line; 66 67 function Down (Str : String) return String is 68 L : constant Natural := Str'Last; 69 begin 70 if Str (L) = '\' then 71 return Str (Str'First .. L - 1) & " \"; 72 elsif Str (L) = '/' then 73 return Str (Str'First .. L - 1) & "| \"; 74 else 75 raise Program_Error; 76 end if; 77 end Down; 78 79 function Up (Str : String) return String is 80 L : constant Natural := Str'Last; 81 begin 82 if Str (L) = '/' then 83 return Str (Str'First .. L - 1) & " /"; 84 elsif Str (L) = '\' then 85 return Str (Str'First .. L - 1) & "| /"; 86 else 87 raise Program_Error; 88 end if; 89 end Up; 90 91 procedure Disp_Repeat_Sequence (Prefix : String; Name : String; N : Node) is 92 S : Node; 93 begin 94 Put_Node (Prefix, Name); 95 Disp_Count (N); 96 Put_Line ("]"); 97 S := Get_Sequence (N); 98 if S /= Null_Node then 99 Disp_Property (Down (Prefix), S); 100 end if; 101 end Disp_Repeat_Sequence; 102 103 procedure Disp_Binary_Sequence (Prefix : String; Name : String; N : Node) is 104 begin 105 Disp_Property (Up (Prefix), Get_Left (N)); 106 Put_Node_Line (Prefix, Name); 107 Disp_Property (Down (Prefix), Get_Right (N)); 108 end Disp_Binary_Sequence; 109 110 procedure Disp_Range_Property (Prefix : String; Name : String; N : Node) is 111 begin 112 Put_Node (Prefix, Name); 113 Put ("["); 114 Disp_Count (N); 115 Put_Line ("]"); 116 Disp_Property (Down (Prefix), Get_Property (N)); 117 end Disp_Range_Property; 118 119 procedure Disp_Boolean_Range_Property (Prefix : String; 120 Name : String; N : Node) is 121 begin 122 Disp_Property (Up (Prefix), Get_Boolean (N)); 123 Put_Node (Prefix, Name); 124 Put ("["); 125 Disp_Count (N); 126 Put_Line ("]"); 127 Disp_Property (Down (Prefix), Get_Property (N)); 128 end Disp_Boolean_Range_Property; 129 130 procedure Disp_Property (Prefix : String; Prop : Node) is 131 begin 132 case Get_Kind (Prop) is 133 when N_Never => 134 Put_Node_Line (Prefix, "never"); 135 Disp_Property (Down (Prefix), Get_Property (Prop)); 136 when N_Always => 137 Put_Node_Line (Prefix, "always"); 138 Disp_Property (Down (Prefix), Get_Property (Prop)); 139 when N_Eventually => 140 Put_Node_Line (Prefix, "eventually!"); 141 Disp_Property (Down (Prefix), Get_Property (Prop)); 142 when N_Next => 143 Put_Node_Line (Prefix, "next"); 144-- if Get_Strong_Flag (Prop) then 145-- Put ('!'); 146-- end if; 147 Disp_Property (Down (Prefix), Get_Property (Prop)); 148 when N_Next_A => 149 Disp_Range_Property (Prefix, "next_a", Prop); 150 when N_Next_E => 151 Disp_Range_Property (Prefix, "next_e", Prop); 152 when N_Next_Event => 153 Disp_Property (Up (Prefix), Get_Boolean (Prop)); 154 Put_Node_Line (Prefix, "next_event"); 155 Disp_Property (Down (Prefix), Get_Property (Prop)); 156 when N_Next_Event_A => 157 Disp_Boolean_Range_Property (Prefix, "next_event_a", Prop); 158 when N_Next_Event_E => 159 Disp_Boolean_Range_Property (Prefix, "next_event_e", Prop); 160 when N_Braced_SERE => 161 Put_Node_Line (Prefix, "{} (braced_SERE)"); 162 Disp_Property (Down (Prefix), Get_SERE (Prop)); 163 when N_Concat_SERE => 164 Disp_Binary_Sequence (Prefix, "; (concat)", Prop); 165 when N_Fusion_SERE => 166 Disp_Binary_Sequence (Prefix, ": (fusion)", Prop); 167 when N_Within_SERE => 168 Disp_Binary_Sequence (Prefix, "within", Prop); 169 when N_Match_And_Seq => 170 Disp_Binary_Sequence (Prefix, "&& (sequence matching len)", Prop); 171 when N_Or_Seq => 172 Disp_Binary_Sequence (Prefix, "| (sequence or)", Prop); 173 when N_And_Seq => 174 Disp_Binary_Sequence (Prefix, "& (sequence and)", Prop); 175 when N_Imp_Seq => 176 Disp_Property (Up (Prefix), Get_Sequence (Prop)); 177 Put_Node_Line (Prefix, "|=> (sequence implication)"); 178 Disp_Property (Down (Prefix), Get_Property (Prop)); 179 when N_Overlap_Imp_Seq => 180 Disp_Property (Up (Prefix), Get_Sequence (Prop)); 181 Put_Node_Line (Prefix, "|->"); 182 Disp_Property (Down (Prefix), Get_Property (Prop)); 183 when N_Or_Prop => 184 Disp_Binary_Sequence (Prefix, "|| (property or)", Prop); 185 when N_And_Prop => 186 Disp_Binary_Sequence (Prefix, "&& (property and)", Prop); 187 when N_Log_Imp_Prop => 188 Disp_Binary_Sequence (Prefix, "-> (property impliciation)", Prop); 189 when N_Until => 190 Disp_Binary_Sequence (Prefix, "until", Prop); 191 when N_Before => 192 Disp_Binary_Sequence (Prefix, "before", Prop); 193 when N_Abort => 194 Disp_Property (Up (Prefix), Get_Property (Prop)); 195 Put_Node_Line (Prefix, "abort"); 196 Disp_Property (Down (Prefix), Get_Boolean (Prop)); 197 when N_Not_Bool => 198 Put_Node_Line (Prefix, "! (boolean not)"); 199 Disp_Property (Down (Prefix), Get_Boolean (Prop)); 200 when N_Or_Bool => 201 Disp_Binary_Sequence (Prefix, "|| (boolean or)", Prop); 202 when N_And_Bool => 203 Disp_Binary_Sequence (Prefix, "&& (boolean and)", Prop); 204 when N_Name_Decl => 205 Put_Node_Line (Prefix, 206 "Name_Decl: " & Image (Get_Identifier (Prop))); 207 when N_Name => 208 Put_Node_Line (Prefix, "Name: " & Image (Get_Identifier (Prop))); 209 Disp_Property (Down (Prefix), Get_Decl (Prop)); 210 when N_True => 211 Put_Node_Line (Prefix, "TRUE"); 212 when N_False => 213 Put_Node_Line (Prefix, "FALSE"); 214 when N_HDL_Expr => 215 Put_Node (Prefix, "HDL_Expr: "); 216 PSL.Prints.HDL_Expr_Printer.all (Get_HDL_Node (Prop)); 217 New_Line; 218 when N_Star_Repeat_Seq => 219 Disp_Repeat_Sequence (Prefix, "[*", Prop); 220 when N_Goto_Repeat_Seq => 221 Disp_Repeat_Sequence (Prefix, "[->", Prop); 222 when N_Equal_Repeat_Seq => 223 Disp_Repeat_Sequence (Prefix, "[=", Prop); 224 when N_Plus_Repeat_Seq => 225 Put_Node_Line (Prefix, "[+]"); 226 Disp_Property (Down (Prefix), Get_Sequence (Prop)); 227 when others => 228 Error_Kind ("disp_property", Prop); 229 end case; 230 end Disp_Property; 231 232 procedure Disp_Assert (N : Node) is 233 Label : constant Name_Id := Get_Label (N); 234 begin 235 Put (" "); 236 if Label /= Null_Identifier then 237 Put (Image (Label)); 238 Put (": "); 239 end if; 240 Put_Line ("assert "); 241 Disp_Property (" \", Get_Property (N)); 242 end Disp_Assert; 243 244 procedure Disp_Unit (Unit : Node) is 245 Item : Node; 246 begin 247 case Get_Kind (Unit) is 248 when N_Vunit => 249 Put ("vunit"); 250 when others => 251 Error_Kind ("disp_unit", Unit); 252 end case; 253 Put (' '); 254 Put (Image (Get_Identifier (Unit))); 255 Put_Line (" {"); 256 Item := Get_Item_Chain (Unit); 257 while Item /= Null_Node loop 258 case Get_Kind (Item) is 259 when N_Assert_Directive => 260 Disp_Assert (Item); 261 when N_Name_Decl => 262 null; 263 when others => 264 Error_Kind ("disp_unit", Item); 265 end case; 266 Item := Get_Chain (Item); 267 end loop; 268 Put_Line ("}"); 269 end Disp_Unit; 270end PSL.Tprint; 271