1-- GHDL Run Time (GRT) - RTI dumper. 2-- Copyright (C) 2002 - 2014 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-- 17-- As a special exception, if other files instantiate generics from this 18-- unit, or you link this unit with other files to produce an executable, 19-- this unit does not by itself cause the resulting executable to be 20-- covered by the GNU General Public License. This exception does not 21-- however invalidate any other reasons why the executable file might be 22-- covered by the GNU Public License. 23 24with Grt.Astdio; use Grt.Astdio; 25with Grt.Astdio.Vhdl; use Grt.Astdio.Vhdl; 26with Grt.Errors; use Grt.Errors; 27with Grt.Hooks; use Grt.Hooks; 28with Grt.Rtis_Utils; use Grt.Rtis_Utils; 29with Grt.Signals; 30 31package body Grt.Disp_Rti is 32 procedure Disp_Kind (Kind : Ghdl_Rtik); 33 34 procedure Disp_Name (Name : Ghdl_C_String) is 35 begin 36 if Name = null then 37 Put (stdout, "<anonymous>"); 38 else 39 Put (stdout, Name); 40 end if; 41 end Disp_Name; 42 43 -- Disp value stored at ADDR and whose type is described by RTI. 44 procedure Disp_Enum_Value 45 (Stream : FILEs; Rti : Ghdl_Rti_Access; Val : Ghdl_Index_Type) 46 is 47 Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := 48 To_Ghdl_Rtin_Type_Enum_Acc (Rti); 49 begin 50 Put (Stream, Enum_Rti.Names (Val)); 51 end Disp_Enum_Value; 52 53 procedure Peek_Value_And_Update (Rti : Ghdl_Rti_Access; 54 Val : out Ghdl_Value_Ptr; 55 Addr : in out Address; 56 Is_Sig : Boolean) 57 is 58 Sz : Ghdl_Index_Type; 59 begin 60 if Is_Sig then 61 -- ADDR is the address of the object. 62 -- The object contains a pointer to the signal. 63 -- The first field of the signal is a pointer to the value. 64 Val := Grt.Signals.To_Ghdl_Signal_Ptr 65 (To_Addr_Acc (Addr).all).Value_Ptr; 66 Sz := Address'Size / Storage_Unit; 67 else 68 Val := To_Ghdl_Value_Ptr (Addr); 69 case Rti.Kind is 70 when Ghdl_Rtik_Type_E8 71 | Ghdl_Rtik_Type_B1 => 72 Sz := 1; 73 when Ghdl_Rtik_Type_I32 74 | Ghdl_Rtik_Type_E32 75 | Ghdl_Rtik_Type_P32 => 76 Sz := 4; 77 when Ghdl_Rtik_Type_F64 78 | Ghdl_Rtik_Type_P64 => 79 Sz := 8; 80 when others => 81 Internal_Error ("disp_rti.peek_value_and_update"); 82 end case; 83 end if; 84 Addr := Addr + Sz; 85 end Peek_Value_And_Update; 86 87 procedure Disp_Scalar_Value (Stream : FILEs; 88 Rti : Ghdl_Rti_Access; 89 Addr : in out Address; 90 Is_Sig : Boolean) 91 is 92 Vptr : Ghdl_Value_Ptr; 93 begin 94 Peek_Value_And_Update (Rti, Vptr, Addr, Is_Sig); 95 96 case Rti.Kind is 97 when Ghdl_Rtik_Type_I32 => 98 Put_I32 (Stream, Vptr.I32); 99 when Ghdl_Rtik_Type_E8 => 100 Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E8)); 101 when Ghdl_Rtik_Type_E32 => 102 Disp_Enum_Value (Stream, Rti, Ghdl_Index_Type (Vptr.E32)); 103 when Ghdl_Rtik_Type_B1 => 104 Disp_Enum_Value (Stream, Rti, 105 Ghdl_Index_Type (Ghdl_B1'Pos (Vptr.B1))); 106 when Ghdl_Rtik_Type_F64 => 107 Put_F64 (Stream, Vptr.F64); 108 when Ghdl_Rtik_Type_P64 => 109 Put_I64 (Stream, Vptr.I64); 110 Put (Stream, " "); 111 Put (Stream, 112 Get_Physical_Unit_Name 113 (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0))); 114 when Ghdl_Rtik_Type_P32 => 115 Put_I32 (Stream, Vptr.I32); 116 Put (Stream, " "); 117 Put (Stream, 118 Get_Physical_Unit_Name 119 (To_Ghdl_Rtin_Type_Physical_Acc (Rti).Units (0))); 120 when others => 121 Internal_Error ("disp_rti.disp_scalar_value"); 122 end case; 123 end Disp_Scalar_Value; 124 125 procedure Disp_Array_As_String (Stream : FILEs; 126 El_Rti : Ghdl_Rti_Access; 127 Length : Ghdl_Index_Type; 128 Obj : in out Address; 129 Is_Sig : Boolean) 130 is 131 Enum_Rti : constant Ghdl_Rtin_Type_Enum_Acc := 132 To_Ghdl_Rtin_Type_Enum_Acc (El_Rti); 133 Name : Ghdl_C_String; 134 135 In_String : Boolean; 136 Val : Ghdl_Value_Ptr; 137 begin 138 In_String := False; 139 140 for I in 1 .. Length loop 141 Peek_Value_And_Update (El_Rti, Val, Obj, Is_Sig); 142 case El_Rti.Kind is 143 when Ghdl_Rtik_Type_E8 => 144 Name := Enum_Rti.Names (Ghdl_Index_Type (Val.E8)); 145 when Ghdl_Rtik_Type_B1 => 146 Name := Enum_Rti.Names (Ghdl_B1'Pos (Val.B1)); 147 when others => 148 Internal_Error ("disp_rti.disp_array_as_string"); 149 end case; 150 if Name (1) = ''' then 151 -- A character. 152 if not In_String then 153 if I /= 1 then 154 Put (Stream, " & "); 155 end if; 156 Put (Stream, '"'); 157 In_String := True; 158 end if; 159 Put (Stream, Name (2)); 160 else 161 if In_String then 162 Put (Stream, '"'); 163 In_String := False; 164 end if; 165 if I /= 1 then 166 Put (Stream, " & "); 167 end if; 168 Put (Stream, Name); 169 end if; 170 end loop; 171 if In_String then 172 Put (Stream, '"'); 173 end if; 174 end Disp_Array_As_String; 175 176-- function Get_Scalar_Type_Kind (Rti : Ghdl_Rti_Access) return Ghdl_Rtik 177-- is 178-- Ndef : Ghdl_Rti_Access; 179-- begin 180-- if Rti.Kind = Ghdl_Rtik_Subtype_Scalar then 181-- Ndef := To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype; 182-- else 183-- Ndef := Rti; 184-- end if; 185-- case Ndef.Kind is 186-- when Ghdl_Rtik_Type_I32 => 187-- return Ndef.Kind; 188-- when others => 189-- return Ghdl_Rtik_Error; 190-- end case; 191-- end Get_Scalar_Type_Kind; 192 193 procedure Disp_Array_Value_1 (Stream : FILEs; 194 Arr_Rti : Ghdl_Rtin_Type_Array_Acc; 195 Ctxt : Rti_Context; 196 Index : Ghdl_Index_Type; 197 Obj : in out Address; 198 Bounds : in out Address; 199 Is_Sig : Boolean) 200 is 201 El_Rti : constant Ghdl_Rti_Access := Arr_Rti.Element; 202 Idx_Rti : constant Ghdl_Rti_Access := 203 Get_Base_Type (Arr_Rti.Indexes (Index)); 204 Last_Idx : constant Ghdl_Index_Type := Arr_Rti.Nbr_Dim - 1; 205 Rng : Ghdl_Range_Ptr; 206 Length : Ghdl_Index_Type; 207 Bounds2 : Address; 208 begin 209 Extract_Range (Bounds, Idx_Rti, Rng); 210 Length := Range_To_Length (Rng, Idx_Rti); 211 212 if Index = Last_Idx 213 and then (El_Rti.Kind = Ghdl_Rtik_Type_B1 214 or else El_Rti.Kind = Ghdl_Rtik_Type_E8) 215 then 216 -- Disp as string. 217 Disp_Array_As_String (Stream, El_Rti, Length, Obj, Is_Sig); 218 return; 219 end if; 220 221 Put (Stream, "("); 222 if Length = 0 then 223 Put (Stream, "<>"); 224 -- FIXME: need to update bounds. 225 else 226 for I in 1 .. Length loop 227 if I /= 1 then 228 Put (Stream, ", "); 229 end if; 230 if Index = Last_Idx then 231 Bounds2 := Array_Layout_To_Element (Bounds, El_Rti); 232 Disp_Value (Stream, El_Rti, Ctxt, Obj, Bounds2, Is_Sig); 233 else 234 Bounds2 := Bounds; 235 Disp_Array_Value_1 236 (Stream, Arr_Rti, Ctxt, Index + 1, Obj, Bounds2, Is_Sig); 237 end if; 238 end loop; 239 Bounds := Bounds2; 240 end if; 241 Put (Stream, ")"); 242 end Disp_Array_Value_1; 243 244 procedure Disp_Record_Value (Stream : FILEs; 245 Rti : Ghdl_Rtin_Type_Record_Acc; 246 Ctxt : Rti_Context; 247 Obj : Address; 248 Obj_Layout : Address; 249 Is_Sig : Boolean) 250 is 251 El : Ghdl_Rtin_Element_Acc; 252 El_Addr : Address; 253 El_Bounds : Address; 254 begin 255 Put (Stream, "("); 256 for I in 1 .. Rti.Nbrel loop 257 El := To_Ghdl_Rtin_Element_Acc (Rti.Elements (I - 1)); 258 if I /= 1 then 259 Put (", "); 260 end if; 261 Put (Stream, El.Name); 262 Put (" => "); 263 Record_To_Element 264 (Obj, El, Is_Sig, Obj_Layout, El_Addr, El_Bounds); 265 Disp_Value (Stream, El.Eltype, Ctxt, El_Addr, El_Bounds, Is_Sig); 266 end loop; 267 Put (")"); 268 -- FIXME: update ADDR. 269 end Disp_Record_Value; 270 271 procedure Disp_Value (Stream : FILEs; 272 Rti : Ghdl_Rti_Access; 273 Ctxt : Rti_Context; 274 Obj : in out Address; 275 Bounds : in out Address; 276 Is_Sig : Boolean) 277 is 278 begin 279 case Rti.Kind is 280 when Ghdl_Rtik_Subtype_Scalar => 281 Disp_Scalar_Value 282 (Stream, To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti).Basetype, 283 Obj, Is_Sig); 284 when Ghdl_Rtik_Type_I32 285 | Ghdl_Rtik_Type_E8 286 | Ghdl_Rtik_Type_E32 287 | Ghdl_Rtik_Type_B1 => 288 Disp_Scalar_Value (Stream, Rti, Obj, Is_Sig); 289 when Ghdl_Rtik_Type_Array => 290 Disp_Array_Value_1 291 (Stream, To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, 0, 292 Obj, Bounds, Is_Sig); 293 when Ghdl_Rtik_Subtype_Unbounded_Array => 294 declare 295 St : constant Ghdl_Rtin_Subtype_Composite_Acc := 296 To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); 297 Bt : constant Ghdl_Rtin_Type_Array_Acc := 298 To_Ghdl_Rtin_Type_Array_Acc (St.Basetype); 299 begin 300 Disp_Array_Value_1 (Stream, Bt, Ctxt, 0, Obj, Bounds, Is_Sig); 301 end; 302 when Ghdl_Rtik_Subtype_Array => 303 declare 304 St : constant Ghdl_Rtin_Subtype_Composite_Acc := 305 To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); 306 Bt : constant Ghdl_Rtin_Type_Array_Acc := 307 To_Ghdl_Rtin_Type_Array_Acc (St.Basetype); 308 Layout : Address; 309 Bounds : Address; 310 begin 311 Layout := Loc_To_Addr (St.Common.Depth, St.Layout, Ctxt); 312 Bounds := Array_Layout_To_Bounds (Layout); 313 Disp_Array_Value_1 (Stream, Bt, Ctxt, 0, Obj, Bounds, Is_Sig); 314 end; 315 when Ghdl_Rtik_Type_File => 316 declare 317 Vptr : Ghdl_Value_Ptr; 318 begin 319 Vptr := To_Ghdl_Value_Ptr (Obj); 320 Put (Stream, "File#"); 321 Put_I32 (Stream, Vptr.I32); 322 -- FIXME: update OBJ (not very useful since never in a 323 -- composite type). 324 end; 325 when Ghdl_Rtik_Type_Record => 326 declare 327 Bt : constant Ghdl_Rtin_Type_Record_Acc := 328 To_Ghdl_Rtin_Type_Record_Acc (Rti); 329 Rec_Layout : Address; 330 begin 331 if Rti_Complex_Type (Rti) then 332 Rec_Layout := Loc_To_Addr (Bt.Common.Depth, Bt.Layout, Ctxt); 333 else 334 Rec_Layout := Bounds; 335 end if; 336 Disp_Record_Value (Stream, Bt, Ctxt, Obj, Rec_Layout, Is_Sig); 337 end; 338 when Ghdl_Rtik_Type_Unbounded_Record => 339 declare 340 Bt : constant Ghdl_Rtin_Type_Record_Acc := 341 To_Ghdl_Rtin_Type_Record_Acc (Rti); 342 begin 343 Disp_Record_Value (Stream, Bt, Ctxt, Obj, Bounds, Is_Sig); 344 end; 345 when Ghdl_Rtik_Subtype_Unbounded_Record => 346 declare 347 St : constant Ghdl_Rtin_Subtype_Composite_Acc := 348 To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); 349 Bt : constant Ghdl_Rtin_Type_Record_Acc := 350 To_Ghdl_Rtin_Type_Record_Acc (St.Basetype); 351 begin 352 Disp_Record_Value (Stream, Bt, Ctxt, Obj, Bounds, Is_Sig); 353 end; 354 when Ghdl_Rtik_Subtype_Record => 355 declare 356 St : constant Ghdl_Rtin_Subtype_Composite_Acc := 357 To_Ghdl_Rtin_Subtype_Composite_Acc (Rti); 358 Bt : constant Ghdl_Rtin_Type_Record_Acc := 359 To_Ghdl_Rtin_Type_Record_Acc (St.Basetype); 360 Layout : Address; 361 begin 362 Layout := Loc_To_Addr (St.Common.Depth, St.Layout, Ctxt); 363 Disp_Record_Value (Stream, Bt, Ctxt, Obj, Layout, Is_Sig); 364 end; 365 when Ghdl_Rtik_Type_Protected => 366 Put (Stream, "Unhandled protected type"); 367 when others => 368 Put (Stream, "Unknown Rti Kind : "); 369 Disp_Kind(Rti.Kind); 370 end case; 371 -- Put_Line(":"); 372 end Disp_Value; 373 374 procedure Disp_Kind (Kind : Ghdl_Rtik) is 375 begin 376 case Kind is 377 when Ghdl_Rtik_Top => 378 Put ("ghdl_rtik_top"); 379 when Ghdl_Rtik_Package => 380 Put ("ghdl_rtik_package"); 381 when Ghdl_Rtik_Package_Body => 382 Put ("ghdl_rtik_package_body"); 383 when Ghdl_Rtik_Entity => 384 Put ("ghdl_rtik_entity"); 385 when Ghdl_Rtik_Architecture => 386 Put ("ghdl_rtik_architecture"); 387 388 when Ghdl_Rtik_Process => 389 Put ("ghdl_rtik_process"); 390 when Ghdl_Rtik_Component => 391 Put ("ghdl_rtik_component"); 392 when Ghdl_Rtik_Attribute => 393 Put ("ghdl_rtik_attribute"); 394 395 when Ghdl_Rtik_Attribute_Quiet => 396 Put ("ghdl_rtik_attribute_quiet"); 397 when Ghdl_Rtik_Attribute_Stable => 398 Put ("ghdl_rtik_attribute_stable"); 399 when Ghdl_Rtik_Attribute_Transaction => 400 Put ("ghdl_rtik_attribute_transaction"); 401 402 when Ghdl_Rtik_Constant => 403 Put ("ghdl_rtik_constant"); 404 when Ghdl_Rtik_Iterator => 405 Put ("ghdl_rtik_iterator"); 406 when Ghdl_Rtik_Signal => 407 Put ("ghdl_rtik_signal"); 408 when Ghdl_Rtik_Variable => 409 Put ("ghdl_rtik_variable"); 410 when Ghdl_Rtik_Guard => 411 Put ("ghdl_rtik_guard"); 412 when Ghdl_Rtik_File => 413 Put ("ghdl_rtik_file"); 414 when Ghdl_Rtik_Port => 415 Put ("ghdl_rtik_port"); 416 when Ghdl_Rtik_Generic => 417 Put ("ghdl_rtik_generic"); 418 when Ghdl_Rtik_Alias => 419 Put ("ghdl_rtik_alias"); 420 421 when Ghdl_Rtik_Instance => 422 Put ("ghdl_rtik_instance"); 423 when Ghdl_Rtik_Block => 424 Put ("ghdl_rtik_block"); 425 when Ghdl_Rtik_If_Generate => 426 Put ("ghdl_rtik_if_generate"); 427 when Ghdl_Rtik_Case_Generate => 428 Put ("ghdl_rtik_case_generate"); 429 when Ghdl_Rtik_For_Generate => 430 Put ("ghdl_rtik_for_generate"); 431 when Ghdl_Rtik_Generate_Body => 432 Put ("ghdl_rtik_generate_body"); 433 434 when Ghdl_Rtik_Type_B1 => 435 Put ("ghdl_rtik_type_b1"); 436 when Ghdl_Rtik_Type_E8 => 437 Put ("ghdl_rtik_type_e8"); 438 when Ghdl_Rtik_Type_E32 => 439 Put ("ghdl_rtik_type_e32"); 440 when Ghdl_Rtik_Type_P64 => 441 Put ("ghdl_rtik_type_p64"); 442 when Ghdl_Rtik_Type_I32 => 443 Put ("ghdl_rtik_type_i32"); 444 445 when Ghdl_Rtik_Type_Array => 446 Put ("ghdl_rtik_type_array"); 447 when Ghdl_Rtik_Subtype_Array => 448 Put ("ghdl_rtik_subtype_array"); 449 when Ghdl_Rtik_Subtype_Unbounded_Array => 450 Put ("ghdl_rtik_subtype_unbounded_array"); 451 452 when Ghdl_Rtik_Type_Record => 453 Put ("ghdl_rtik_type_record"); 454 when Ghdl_Rtik_Type_Unbounded_Record => 455 Put ("ghdl_rtik_type_unbounded_record"); 456 when Ghdl_Rtik_Subtype_Unbounded_Record => 457 Put ("ghdl_rtik_subtype_unbounded_record"); 458 when Ghdl_Rtik_Subtype_Record => 459 Put ("ghdl_rtik_subtype_record"); 460 461 when Ghdl_Rtik_Type_Access => 462 Put ("ghdl_rtik_type_access"); 463 when Ghdl_Rtik_Type_File => 464 Put ("ghdl_rtik_type_file"); 465 when Ghdl_Rtik_Type_Protected => 466 Put ("ghdl_rtik_type_protected"); 467 468 when Ghdl_Rtik_Subtype_Scalar => 469 Put ("ghdl_rtik_subtype_scalar"); 470 471 when Ghdl_Rtik_Element => 472 Put ("ghdl_rtik_element"); 473 when Ghdl_Rtik_Unit64 => 474 Put ("ghdl_rtik_unit64"); 475 when Ghdl_Rtik_Unitptr => 476 Put ("ghdl_rtik_unitptr"); 477 478 when Ghdl_Rtik_Psl_Assert => 479 Put ("ghdl_rtik_psl_assert"); 480 when Ghdl_Rtik_Psl_Assume => 481 Put ("ghdl_rtik_psl_assume"); 482 when Ghdl_Rtik_Psl_Cover => 483 Put ("ghdl_rtik_psl_cover"); 484 when Ghdl_Rtik_Psl_Endpoint => 485 Put ("ghdl_rtik_psl_endpoint"); 486 487 when others => 488 -- Should never happen, except when not synchronized. 489 Put ("ghdl_rtik_#"); 490 Put_I32 (stdout, Ghdl_Rtik'Pos (Kind)); 491 end case; 492 end Disp_Kind; 493 494 procedure Disp_Depth (Depth : Ghdl_Rti_Depth) is 495 begin 496 Put (", D="); 497 Put_I32 (stdout, Ghdl_I32 (Depth)); 498 end Disp_Depth; 499 500 procedure Disp_Indent (Indent : Natural) is 501 begin 502 for I in 1 .. Indent loop 503 Put (' '); 504 end loop; 505 end Disp_Indent; 506 507 -- Disp a subtype_indication. 508 -- OBJ may be necessary when the subtype is an unconstrained array type, 509 -- whose bounds are stored with the object. 510 procedure Disp_Subtype_Indication 511 (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address); 512 513 procedure Disp_Range 514 (Stream : FILEs; Def : Ghdl_Rti_Access; Rng : Ghdl_Range_Ptr) is 515 begin 516 case Def.Kind is 517 when Ghdl_Rtik_Type_I32 518 | Ghdl_Rtik_Type_P32 => 519 Put_I32 (Stream, Rng.I32.Left); 520 Put_Dir (Stream, Rng.I32.Dir); 521 Put_I32 (Stream, Rng.I32.Right); 522 when Ghdl_Rtik_Type_F64 => 523 Put_F64 (Stream, Rng.F64.Left); 524 Put_Dir (Stream, Rng.F64.Dir); 525 Put_F64 (Stream, Rng.F64.Right); 526 when Ghdl_Rtik_Type_P64 => 527 Put_I64 (Stream, Rng.P64.Left); 528 Put_Dir (Stream, Rng.P64.Dir); 529 Put_I64 (Stream, Rng.P64.Right); 530 when Ghdl_Rtik_Type_B1 => 531 declare 532 Enum : constant Ghdl_Rtin_Type_Enum_Acc := 533 To_Ghdl_Rtin_Type_Enum_Acc (Def); 534 begin 535 Disp_Name (Enum.Names (Ghdl_B1'Pos (Rng.B1.Left))); 536 Put_Dir (Stream, Rng.B1.Dir); 537 Disp_Name (Enum.Names (Ghdl_B1'Pos (Rng.B1.Right))); 538 end; 539 when Ghdl_Rtik_Type_E8 => 540 declare 541 Enum : constant Ghdl_Rtin_Type_Enum_Acc := 542 To_Ghdl_Rtin_Type_Enum_Acc (Def); 543 begin 544 Disp_Name (Enum.Names (Ghdl_E8'Pos (Rng.E8.Left))); 545 Put_Dir (Stream, Rng.E8.Dir); 546 Disp_Name (Enum.Names (Ghdl_E8'Pos (Rng.E8.Right))); 547 end; 548 when others => 549 Put ("?Scal"); 550 end case; 551 end Disp_Range; 552 553 procedure Disp_Scalar_Type_Name (Def : Ghdl_Rti_Access) is 554 begin 555 case Def.Kind is 556 when Ghdl_Rtik_Subtype_Scalar => 557 declare 558 Rti : Ghdl_Rtin_Subtype_Scalar_Acc; 559 begin 560 Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def); 561 if Rti.Name /= null then 562 Disp_Name (Rti.Name); 563 else 564 Disp_Scalar_Type_Name (Rti.Basetype); 565 end if; 566 end; 567 when Ghdl_Rtik_Type_B1 568 | Ghdl_Rtik_Type_E8 569 | Ghdl_Rtik_Type_E32 => 570 Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name); 571 when Ghdl_Rtik_Type_I32 572 | Ghdl_Rtik_Type_I64 => 573 Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); 574 when others => 575 Put ("#disp_scalar_type_name#"); 576 end case; 577 end Disp_Scalar_Type_Name; 578 579 procedure Disp_Type_Composite_Bounds 580 (Def : Ghdl_Rti_Access; Bounds : Address); 581 582 procedure Disp_Type_Array_Bounds (Def : Ghdl_Rtin_Type_Array_Acc; 583 Bounds : Address) 584 is 585 Rng : Ghdl_Range_Ptr; 586 Idx_Base : Ghdl_Rti_Access; 587 Bounds1 : Address; 588 El_Type : Ghdl_Rti_Access; 589 begin 590 Bounds1 := Bounds; 591 Put (" ("); 592 for I in 0 .. Def.Nbr_Dim - 1 loop 593 if I /= 0 then 594 Put (", "); 595 end if; 596 if Boolean'(False) then 597 Disp_Scalar_Type_Name (Def.Indexes (I)); 598 Put (" range "); 599 end if; 600 Idx_Base := Get_Base_Type (Def.Indexes (I)); 601 Extract_Range (Bounds1, Idx_Base, Rng); 602 Disp_Range (stdout, Idx_Base, Rng); 603 end loop; 604 Put (")"); 605 El_Type := Def.Element; 606 if Is_Unbounded (El_Type) then 607 Disp_Type_Composite_Bounds (El_Type, Bounds1); 608 end if; 609 end Disp_Type_Array_Bounds; 610 611 procedure Disp_Type_Record_Bounds (Def : Ghdl_Rtin_Type_Record_Acc; 612 Layout : Address) 613 is 614 El : Ghdl_Rtin_Element_Acc; 615 El_Layout : Address; 616 El_Type : Ghdl_Rti_Access; 617 First : Boolean; 618 begin 619 Put (" ("); 620 First := True; 621 for I in 1 .. Def.Nbrel loop 622 El := To_Ghdl_Rtin_Element_Acc (Def.Elements (I - 1)); 623 El_Type := El.Eltype; 624 if Is_Unbounded (El_Type) then 625 if First then 626 First := False; 627 else 628 Put (", "); 629 end if; 630 Put (El.Name); 631 El_Layout := Layout + El.Layout_Off; 632 Disp_Type_Composite_Bounds (El_Type, El_Layout); 633 end if; 634 end loop; 635 Put (")"); 636 end Disp_Type_Record_Bounds; 637 638 639 procedure Disp_Type_Composite_Bounds 640 (Def : Ghdl_Rti_Access; Bounds : Address) 641 is 642 El_Type : constant Ghdl_Rti_Access := Get_Base_Type (Def); 643 begin 644 case El_Type.Kind is 645 when Ghdl_Rtik_Type_Array => 646 Disp_Type_Array_Bounds 647 (To_Ghdl_Rtin_Type_Array_Acc (El_Type), 648 Array_Layout_To_Bounds (Bounds)); 649 when Ghdl_Rtik_Type_Unbounded_Record => 650 Disp_Type_Record_Bounds 651 (To_Ghdl_Rtin_Type_Record_Acc (El_Type), Bounds); 652 when others => 653 raise Program_Error; 654 end case; 655 end Disp_Type_Composite_Bounds; 656 657 procedure Disp_Type_Array_Name (Def : Ghdl_Rtin_Type_Array_Acc; 658 Bounds_Ptr : Address) 659 is 660 Bounds : Address; 661 begin 662 Disp_Name (Def.Name); 663 if Bounds_Ptr = Null_Address then 664 return; 665 end if; 666 Bounds := Bounds_Ptr; 667 Disp_Type_Array_Bounds (Def, Bounds); 668 end Disp_Type_Array_Name; 669 670 procedure Disp_Type_Record_Name (Def : Ghdl_Rtin_Type_Record_Acc; 671 Layout_Ptr : Address) 672 is 673 Layout : Address; 674 begin 675 Disp_Name (Def.Name); 676 if Layout_Ptr = Null_Address then 677 return; 678 end if; 679 Layout := Layout_Ptr; 680 Disp_Type_Record_Bounds (Def, Layout); 681 end Disp_Type_Record_Name; 682 683 procedure Disp_Subtype_Scalar_Range 684 (Stream : FILEs; Def : Ghdl_Rtin_Subtype_Scalar_Acc; Ctxt : Rti_Context) 685 is 686 Range_Addr : Address; 687 Rng : Ghdl_Range_Ptr; 688 begin 689 Range_Addr := Loc_To_Addr (Def.Common.Depth, 690 Def.Range_Loc, Ctxt); 691 Rng := To_Ghdl_Range_Ptr (Range_Addr); 692 Disp_Range (Stream, Def.Basetype, Rng); 693 end Disp_Subtype_Scalar_Range; 694 695 procedure Disp_Subtype_Indication 696 (Def : Ghdl_Rti_Access; Ctxt : Rti_Context; Obj : Address) 697 is 698 begin 699 case Def.Kind is 700 when Ghdl_Rtik_Subtype_Scalar => 701 declare 702 Rti : Ghdl_Rtin_Subtype_Scalar_Acc; 703 begin 704 Rti := To_Ghdl_Rtin_Subtype_Scalar_Acc (Def); 705 if Rti.Name /= null then 706 Disp_Name (Rti.Name); 707 else 708 Disp_Subtype_Indication 709 (Rti.Basetype, Null_Context, Null_Address); 710 Put (" range "); 711 Disp_Subtype_Scalar_Range (stdout, Rti, Ctxt); 712 end if; 713 end; 714 --Disp_Scalar_Subtype_Name (To_Ghdl_Rtin_Scalsubtype_Acc (Def), 715 -- Base); 716 when Ghdl_Rtik_Type_B1 717 | Ghdl_Rtik_Type_E8 718 | Ghdl_Rtik_Type_E32 => 719 Disp_Name (To_Ghdl_Rtin_Type_Enum_Acc (Def).Name); 720 when Ghdl_Rtik_Type_I32 721 | Ghdl_Rtik_Type_I64 => 722 Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); 723 when Ghdl_Rtik_Type_File 724 | Ghdl_Rtik_Type_Access => 725 Disp_Name (To_Ghdl_Rtin_Type_Fileacc_Acc (Def).Name); 726 when Ghdl_Rtik_Type_Record 727 | Ghdl_Rtik_Type_Unbounded_Record => 728 Disp_Name (To_Ghdl_Rtin_Type_Record_Acc (Def).Name); 729 when Ghdl_Rtik_Subtype_Record => 730 declare 731 Sdef : constant Ghdl_Rtin_Subtype_Composite_Acc := 732 To_Ghdl_Rtin_Subtype_Composite_Acc (Def); 733 begin 734 if Sdef.Name /= null then 735 Disp_Name (Sdef.Name); 736 else 737 Disp_Type_Record_Name 738 (To_Ghdl_Rtin_Type_Record_Acc (Sdef.Basetype), 739 Loc_To_Addr (Sdef.Common.Depth, Sdef.Layout, Ctxt)); 740 end if; 741 end; 742 when Ghdl_Rtik_Type_Array => 743 declare 744 Bounds : Address; 745 begin 746 if Obj = Null_Address then 747 Bounds := Null_Address; 748 else 749 Bounds := To_Ghdl_Uc_Array_Acc (Obj).Bounds; 750 end if; 751 Disp_Type_Array_Name (To_Ghdl_Rtin_Type_Array_Acc (Def), 752 Bounds); 753 end; 754 when Ghdl_Rtik_Subtype_Array => 755 declare 756 Sdef : constant Ghdl_Rtin_Subtype_Composite_Acc := 757 To_Ghdl_Rtin_Subtype_Composite_Acc (Def); 758 Layout : Address; 759 begin 760 if Sdef.Name /= null then 761 Disp_Name (Sdef.Name); 762 else 763 Layout := Loc_To_Addr (Sdef.Common.Depth, Sdef.Layout, Ctxt); 764 Disp_Type_Array_Name 765 (To_Ghdl_Rtin_Type_Array_Acc (Sdef.Basetype), 766 Array_Layout_To_Bounds (Layout)); 767 end if; 768 end; 769 when Ghdl_Rtik_Subtype_Unbounded_Array => 770 declare 771 Sdef : constant Ghdl_Rtin_Subtype_Composite_Acc := 772 To_Ghdl_Rtin_Subtype_Composite_Acc (Def); 773 begin 774 if Sdef.Name /= null then 775 Disp_Name (Sdef.Name); 776 else 777 Put ("?sub-arr?"); 778 end if; 779 end; 780 when Ghdl_Rtik_Type_Protected => 781 Disp_Name (To_Ghdl_Rtin_Type_Scalar_Acc (Def).Name); 782 when others => 783 Disp_Kind (Def.Kind); 784 Put (' '); 785 end case; 786 end Disp_Subtype_Indication; 787 788 procedure Disp_Linecol (Linecol : Ghdl_Index_Type) is 789 begin 790 Put ("sloc="); 791 Put_U32 (stdout, Get_Linecol_Line (Linecol)); 792 Put (":"); 793 Put_U32 (stdout, Get_Linecol_Col (Linecol)); 794 end Disp_Linecol; 795 796 procedure Disp_Rti (Rti : Ghdl_Rti_Access; 797 Ctxt : Rti_Context; 798 Indent : Natural); 799 800 procedure Disp_Rti_Arr (Nbr : Ghdl_Index_Type; 801 Arr : Ghdl_Rti_Arr_Acc; 802 Ctxt : Rti_Context; 803 Indent : Natural) 804 is 805 begin 806 for I in 1 .. Nbr loop 807 Disp_Rti (Arr (I - 1), Ctxt, Indent); 808 end loop; 809 end Disp_Rti_Arr; 810 811 procedure Disp_Block (Blk : Ghdl_Rtin_Block_Acc; 812 Ctxt : Rti_Context; 813 Indent : Natural) 814 is 815 Nctxt : Rti_Context; 816 begin 817 Disp_Indent (Indent); 818 Disp_Kind (Blk.Common.Kind); 819 Disp_Depth (Blk.Common.Depth); 820 Put (", "); 821 Disp_Linecol (Blk.Linecol); 822 Put (": "); 823 Disp_Name (Blk.Name); 824 New_Line; 825 case Blk.Common.Kind is 826 when Ghdl_Rtik_Package 827 | Ghdl_Rtik_Package_Body 828 | Ghdl_Rtik_Entity 829 | Ghdl_Rtik_Architecture => 830 Disp_Indent (Indent); 831 Put (" filename: "); 832 Disp_Name (To_Ghdl_Rtin_Block_Filename_Acc 833 (To_Ghdl_Rti_Access (Blk)).Filename); 834 New_Line; 835 when others => 836 null; 837 end case; 838 if Blk.Parent /= null then 839 case Blk.Common.Kind is 840 when Ghdl_Rtik_Architecture => 841 -- Disp entity. 842 Disp_Rti (Blk.Parent, Ctxt, Indent + 1); 843 when others => 844 null; 845 end case; 846 end if; 847 case Blk.Common.Kind is 848 when Ghdl_Rtik_Package 849 | Ghdl_Rtik_Package_Body 850 | Ghdl_Rtik_Entity 851 | Ghdl_Rtik_Architecture 852 | Ghdl_Rtik_Block 853 | Ghdl_Rtik_Process => 854 Nctxt := (Base => Ctxt.Base + Blk.Loc, 855 Block => To_Ghdl_Rti_Access (Blk)); 856 Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, 857 Nctxt, Indent + 1); 858 when Ghdl_Rtik_Generate_Body => 859 Disp_Rti_Arr (Blk.Nbr_Child, Blk.Children, 860 Ctxt, Indent + 1); 861 when Ghdl_Rtik_If_Generate 862 | Ghdl_Rtik_Case_Generate => 863 Nctxt := Get_If_Case_Generate_Child 864 (Ctxt, To_Ghdl_Rti_Access (Blk)); 865 if Nctxt /= Null_Context then 866 -- There might be no blocks. 867 Disp_Block 868 (To_Ghdl_Rtin_Block_Acc (Nctxt.Block), Nctxt, Indent + 1); 869 end if; 870 when others => 871 Internal_Error ("disp_block"); 872 end case; 873 end Disp_Block; 874 875 procedure Disp_For_Generate (Gen : Ghdl_Rtin_Generate_Acc; 876 Ctxt : Rti_Context; 877 Indent : Natural) 878 is 879 Nctxt : Rti_Context; 880 Length : Ghdl_Index_Type; 881 begin 882 Disp_Indent (Indent); 883 Disp_Kind (Gen.Common.Kind); 884 Disp_Depth (Gen.Common.Depth); 885 Put (", "); 886 Disp_Linecol (Gen.Linecol); 887 Put (": "); 888 Disp_Name (Gen.Name); 889 New_Line; 890 891 Nctxt := (Base => To_Addr_Acc (Ctxt.Base + Gen.Loc).all, 892 Block => Gen.Child); 893 Length := Get_For_Generate_Length (Gen, Ctxt); 894 for I in 1 .. Length loop 895 Disp_Block (To_Ghdl_Rtin_Block_Acc (Gen.Child), 896 Nctxt, Indent + 1); 897 Nctxt.Base := Nctxt.Base + Gen.Size; 898 end loop; 899 end Disp_For_Generate; 900 901 procedure Disp_Obj_Header (Obj : Ghdl_Rtin_Object_Acc; Indent : Natural) is 902 begin 903 Disp_Indent (Indent); 904 Disp_Kind (Obj.Common.Kind); 905 Disp_Depth (Obj.Common.Depth); 906 Put (", "); 907 Disp_Linecol (Obj.Linecol); 908 Put ("; "); 909 Disp_Name (Obj.Name); 910 Put (": "); 911 end Disp_Obj_Header; 912 913 procedure Disp_Object (Obj : Ghdl_Rtin_Object_Acc; 914 Is_Sig : Boolean; 915 Ctxt : Rti_Context; 916 Indent : Natural) 917 is 918 Obj_Addr, Base, Bounds : Address; 919 Obj_Type : Ghdl_Rti_Access; 920 begin 921 Disp_Obj_Header (Obj, Indent); 922 923 Obj_Addr := Loc_To_Addr (Obj.Common.Depth, Obj.Loc, Ctxt); 924 Obj_Type := Obj.Obj_Type; 925 Disp_Subtype_Indication (Obj_Type, Ctxt, Obj_Addr); 926 Put (" := "); 927 928 Object_To_Base_Bounds (Obj_Type, Obj_Addr, Base, Bounds); 929 Disp_Value (stdout, Obj_Type, Ctxt, Base, Bounds, Is_Sig); 930 New_Line; 931 end Disp_Object; 932 933 procedure Disp_Psl_Directive (Obj : Ghdl_Rtin_Object_Acc; 934 Ctxt : Rti_Context; 935 Indent : Natural) 936 is 937 Addr : Address; 938 begin 939 Disp_Obj_Header (Obj, Indent); 940 Put ("count = "); 941 Addr := Loc_To_Addr (Obj.Common.Depth, Obj.Loc, Ctxt); 942 Put_U32 (stdout, Ghdl_U32 (To_Ghdl_Index_Ptr (Addr).all)); 943 New_Line; 944 end Disp_Psl_Directive; 945 946 procedure Disp_Psl_Endpoint_Directive (Obj : Ghdl_Rtin_Object_Acc; 947 Ctxt : Rti_Context; 948 Indent : Natural) 949 is 950 Addr : Address; 951 C : Character; 952 begin 953 Disp_Obj_Header (Obj, Indent); 954 Put ("endpoint = "); 955 Addr := Loc_To_Addr (Obj.Common.Depth, Obj.Loc, Ctxt); 956 if To_Ghdl_Value_Ptr (Addr).B1 then 957 C := 'T'; 958 else 959 C := 'F'; 960 end if; 961 Put (stdout, C); 962 New_Line; 963 end Disp_Psl_Endpoint_Directive; 964 965 procedure Disp_Attribute (Obj : Ghdl_Rtin_Object_Acc; 966 Ctxt : Rti_Context; 967 Indent : Natural) 968 is 969 begin 970 Disp_Indent (Indent); 971 Disp_Kind (Obj.Common.Kind); 972 Disp_Depth (Obj.Common.Depth); 973 Put ("; "); 974 Disp_Name (Obj.Name); 975 Put (": "); 976 Disp_Subtype_Indication (Obj.Obj_Type, Ctxt, Null_Address); 977 New_Line; 978 end Disp_Attribute; 979 980 procedure Disp_Component (Comp : Ghdl_Rtin_Component_Acc; 981 Indent : Natural) 982 is 983 begin 984 Disp_Indent (Indent); 985 Disp_Kind (Comp.Common.Kind); 986 Disp_Depth (Comp.Common.Depth); 987 Put (": "); 988 Disp_Name (Comp.Name); 989 New_Line; 990 --Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Base, Ident + 1); 991 end Disp_Component; 992 993 procedure Disp_Instance (Inst : Ghdl_Rtin_Instance_Acc; 994 Ctxt : Rti_Context; 995 Indent : Natural) 996 is 997 Inst_Addr : Address; 998 Inst_Base : Address; 999 Inst_Rti : Ghdl_Rti_Access; 1000 Nindent : Natural; 1001 Nctxt : Rti_Context; 1002 begin 1003 Disp_Indent (Indent); 1004 Disp_Kind (Inst.Common.Kind); 1005 Put (", "); 1006 Disp_Linecol (Inst.Linecol); 1007 Put (": "); 1008 Disp_Name (Inst.Name); 1009 New_Line; 1010 1011 Inst_Addr := Ctxt.Base + Inst.Loc; 1012 -- Read sub instance. 1013 Inst_Base := To_Addr_Acc (Inst_Addr).all; 1014 1015 Nindent := Indent + 1; 1016 1017 case Inst.Instance.Kind is 1018 when Ghdl_Rtik_Component => 1019 declare 1020 Comp : Ghdl_Rtin_Component_Acc; 1021 begin 1022 Comp := To_Ghdl_Rtin_Component_Acc (Inst.Instance); 1023 Disp_Indent (Nindent); 1024 Disp_Kind (Comp.Common.Kind); 1025 Put (": "); 1026 Disp_Name (Comp.Name); 1027 New_Line; 1028 -- Disp components generics and ports. 1029 -- FIXME: the data to disp are at COMP_BASE. 1030 Nctxt := (Base => Inst_Addr, 1031 Block => Inst.Instance); 1032 Nindent := Nindent + 1; 1033 Disp_Rti_Arr (Comp.Nbr_Child, Comp.Children, Nctxt, Nindent); 1034 Nindent := Nindent + 1; 1035 end; 1036 when Ghdl_Rtik_Entity => 1037 null; 1038 when others => 1039 null; 1040 end case; 1041 1042 -- Read instance RTI. 1043 if Inst_Base /= Null_Address then 1044 Inst_Rti := To_Ghdl_Rti_Acc_Acc (Inst_Base).all; 1045 Nctxt := (Base => Inst_Base, 1046 Block => Inst_Rti); 1047 Disp_Block (To_Ghdl_Rtin_Block_Acc (Inst_Rti), 1048 Nctxt, Nindent); 1049 end if; 1050 end Disp_Instance; 1051 1052 procedure Disp_Type_Enum_Decl (Enum : Ghdl_Rtin_Type_Enum_Acc; 1053 Indent : Natural) 1054 is 1055 begin 1056 Disp_Indent (Indent); 1057 Disp_Kind (Enum.Common.Kind); 1058 Put (": "); 1059 Disp_Name (Enum.Name); 1060 Put (" is ("); 1061 Disp_Name (Enum.Names (0)); 1062 for I in 1 .. Enum.Nbr - 1 loop 1063 Put (", "); 1064 Disp_Name (Enum.Names (I)); 1065 end loop; 1066 Put (")"); 1067 New_Line; 1068 end Disp_Type_Enum_Decl; 1069 1070 procedure Disp_Subtype_Scalar_Decl (Def : Ghdl_Rtin_Subtype_Scalar_Acc; 1071 Ctxt : Rti_Context; 1072 Indent : Natural) 1073 is 1074 Bt : Ghdl_Rti_Access; 1075 begin 1076 Disp_Indent (Indent); 1077 Disp_Kind (Def.Common.Kind); 1078 Disp_Depth (Def.Common.Depth); 1079 Put (": "); 1080 Disp_Name (Def.Name); 1081 Put (" is "); 1082 Bt := Def.Basetype; 1083 case Bt.Kind is 1084 when Ghdl_Rtik_Type_I32 1085 | Ghdl_Rtik_Type_F64 1086 | Ghdl_Rtik_Type_E8 1087 | Ghdl_Rtik_Type_E32 => 1088 declare 1089 Bdef : Ghdl_Rtin_Type_Scalar_Acc; 1090 begin 1091 Bdef := To_Ghdl_Rtin_Type_Scalar_Acc (Bt); 1092 if Bdef.Name /= Def.Name then 1093 Disp_Name (Bdef.Name); 1094 Put (" range "); 1095 end if; 1096 -- This is the type definition. 1097 Disp_Subtype_Scalar_Range (stdout, Def, Ctxt); 1098 end; 1099 when Ghdl_Rtik_Type_P64 1100 | Ghdl_Rtik_Type_P32 => 1101 declare 1102 Bdef : Ghdl_Rtin_Type_Physical_Acc; 1103 Unit : Ghdl_Rti_Access; 1104 begin 1105 Bdef := To_Ghdl_Rtin_Type_Physical_Acc (Bt); 1106 if Bdef.Name /= Def.Name then 1107 Disp_Name (Bdef.Name); 1108 Put (" range "); 1109 end if; 1110 -- This is the type definition. 1111 Disp_Subtype_Scalar_Range (stdout, Def, Ctxt); 1112 if Bdef.Name = Def.Name then 1113 for I in 0 .. Bdef.Nbr - 1 loop 1114 Unit := Bdef.Units (I); 1115 New_Line; 1116 Disp_Indent (Indent + 1); 1117 Disp_Kind (Unit.Kind); 1118 Put (": "); 1119 Disp_Name (Get_Physical_Unit_Name (Unit)); 1120 Put (" = "); 1121 case Unit.Kind is 1122 when Ghdl_Rtik_Unit64 => 1123 Put_I64 (stdout, 1124 To_Ghdl_Rtin_Unit64_Acc (Unit).Value); 1125 when Ghdl_Rtik_Unitptr => 1126 case Bt.Kind is 1127 when Ghdl_Rtik_Type_P64 => 1128 Put_I64 1129 (stdout, 1130 To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I64); 1131 when Ghdl_Rtik_Type_P32 => 1132 Put_I32 1133 (stdout, 1134 To_Ghdl_Rtin_Unitptr_Acc (Unit).Addr.I32); 1135 when others => 1136 Internal_Error 1137 ("disp_rti.subtype.scalar_decl(P32/P64)"); 1138 end case; 1139 when others => 1140 Internal_Error 1141 ("disp_rti.subtype.scalar_decl(P32/P64)"); 1142 end case; 1143 end loop; 1144 end if; 1145 end; 1146 when others => 1147 Disp_Subtype_Indication 1148 (To_Ghdl_Rti_Access (Def), Ctxt, Null_Address); 1149 end case; 1150 New_Line; 1151 end Disp_Subtype_Scalar_Decl; 1152 1153 procedure Disp_Type_Array_Decl (Def : Ghdl_Rtin_Type_Array_Acc; 1154 Ctxt : Rti_Context; 1155 Indent : Natural) 1156 is 1157 begin 1158 Disp_Indent (Indent); 1159 Disp_Kind (Def.Common.Kind); 1160 Put (": "); 1161 Disp_Name (Def.Name); 1162 Put (" is array ("); 1163 for I in 0 .. Def.Nbr_Dim - 1 loop 1164 if I /= 0 then 1165 Put (", "); 1166 end if; 1167 Disp_Subtype_Indication (Def.Indexes (I), Ctxt, Null_Address); 1168 Put (" range <>"); 1169 end loop; 1170 Put (") of "); 1171 Disp_Subtype_Indication (Def.Element, Ctxt, Null_Address); 1172 New_Line; 1173 end Disp_Type_Array_Decl; 1174 1175 procedure Disp_Subtype_Array_Decl (Def : Ghdl_Rtin_Subtype_Composite_Acc; 1176 Ctxt : Rti_Context; 1177 Indent : Natural) 1178 is 1179 Basetype : constant Ghdl_Rtin_Type_Array_Acc := 1180 To_Ghdl_Rtin_Type_Array_Acc (Def.Basetype); 1181 Layout : Address; 1182 begin 1183 Disp_Indent (Indent); 1184 Disp_Kind (Def.Common.Kind); 1185 Put (": "); 1186 Disp_Name (Def.Name); 1187 Put (" is "); 1188 Layout := Loc_To_Addr (Def.Common.Depth, Def.Layout, Ctxt); 1189 Disp_Type_Array_Name (Basetype, Array_Layout_To_Bounds (Layout)); 1190 if Rti_Anonymous_Type (To_Ghdl_Rti_Access (Basetype)) then 1191 Put (" of "); 1192 Disp_Subtype_Indication (Basetype.Element, Ctxt, Null_Address); 1193 end if; 1194 New_Line; 1195 end Disp_Subtype_Array_Decl; 1196 1197 procedure Disp_Subtype_Unbounded_Array_Decl 1198 (Def : Ghdl_Rtin_Subtype_Composite_Acc; 1199 Ctxt : Rti_Context; 1200 Indent : Natural) 1201 is 1202 pragma Unreferenced (Ctxt); 1203 Basetype : constant Ghdl_Rtin_Type_Array_Acc := 1204 To_Ghdl_Rtin_Type_Array_Acc (Def.Basetype); 1205 begin 1206 Disp_Indent (Indent); 1207 Disp_Kind (Def.Common.Kind); 1208 Put (": "); 1209 Disp_Name (Def.Name); 1210 Put (" is "); 1211 Disp_Name (Basetype.Name); 1212 New_Line; 1213 end Disp_Subtype_Unbounded_Array_Decl; 1214 1215 procedure Disp_Type_File_Or_Access (Def : Ghdl_Rtin_Type_Fileacc_Acc; 1216 Ctxt : Rti_Context; 1217 Indent : Natural) 1218 is 1219 begin 1220 Disp_Indent (Indent); 1221 Disp_Kind (Def.Common.Kind); 1222 Put (": "); 1223 Disp_Name (Def.Name); 1224 Put (" is "); 1225 case Def.Common.Kind is 1226 when Ghdl_Rtik_Type_Access => 1227 Put ("access "); 1228 when Ghdl_Rtik_Type_File => 1229 Put ("file "); 1230 when others => 1231 Put ("?? "); 1232 end case; 1233 Disp_Subtype_Indication (Def.Base, Ctxt, Null_Address); 1234 New_Line; 1235 end Disp_Type_File_Or_Access; 1236 1237 procedure Disp_Type_Record (Def : Ghdl_Rtin_Type_Record_Acc; 1238 Ctxt : Rti_Context; 1239 Indent : Natural) 1240 is 1241 El : Ghdl_Rtin_Element_Acc; 1242 begin 1243 Disp_Indent (Indent); 1244 Disp_Kind (Def.Common.Kind); 1245 Put (": "); 1246 Disp_Name (Def.Name); 1247 Put (" is record"); 1248 New_Line; 1249 for I in 1 .. Def.Nbrel loop 1250 El := To_Ghdl_Rtin_Element_Acc (Def.Elements (I - 1)); 1251 Disp_Indent (Indent + 1); 1252 Disp_Kind (El.Common.Kind); 1253 Put (": "); 1254 Disp_Name (El.Name); 1255 Put (": "); 1256 Disp_Subtype_Indication (El.Eltype, Ctxt, Null_Address); 1257 New_Line; 1258 end loop; 1259 end Disp_Type_Record; 1260 1261 procedure Disp_Subtype_Record_Decl (Def : Ghdl_Rtin_Subtype_Composite_Acc; 1262 Ctxt : Rti_Context; 1263 Indent : Natural) 1264 is 1265 Basetype : constant Ghdl_Rtin_Type_Record_Acc := 1266 To_Ghdl_Rtin_Type_Record_Acc (Def.Basetype); 1267 Layout : Address; 1268 begin 1269 Disp_Indent (Indent); 1270 Disp_Kind (Def.Common.Kind); 1271 Put (": "); 1272 Disp_Name (Def.Name); 1273 Put (" is "); 1274 Disp_Name (Basetype.Name); 1275 if Def.Common.Kind = Ghdl_Rtik_Subtype_Record then 1276 Layout := Loc_To_Addr (Def.Common.Depth, Def.Layout, Ctxt); 1277 Disp_Type_Record_Bounds (Basetype, Layout); 1278 end if; 1279 New_Line; 1280 end Disp_Subtype_Record_Decl; 1281 1282 procedure Disp_Type_Protected (Def : Ghdl_Rtin_Type_Scalar_Acc; 1283 Ctxt : Rti_Context; 1284 Indent : Natural) 1285 is 1286 pragma Unreferenced (Ctxt); 1287 begin 1288 Disp_Indent (Indent); 1289 Disp_Kind (Def.Common.Kind); 1290 Put (": "); 1291 Disp_Name (Def.Name); 1292 Put (" is protected"); 1293 New_Line; 1294 end Disp_Type_Protected; 1295 1296 procedure Disp_Rti (Rti : Ghdl_Rti_Access; 1297 Ctxt : Rti_Context; 1298 Indent : Natural) 1299 is 1300 begin 1301 if Rti = null then 1302 return; 1303 end if; 1304 1305 case Rti.Kind is 1306 when Ghdl_Rtik_Entity 1307 | Ghdl_Rtik_Architecture 1308 | Ghdl_Rtik_Package 1309 | Ghdl_Rtik_Process 1310 | Ghdl_Rtik_Block => 1311 Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent); 1312 when Ghdl_Rtik_If_Generate 1313 | Ghdl_Rtik_Case_Generate => 1314 Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent); 1315 when Ghdl_Rtik_For_Generate => 1316 Disp_For_Generate (To_Ghdl_Rtin_Generate_Acc (Rti), Ctxt, Indent); 1317 when Ghdl_Rtik_Package_Body => 1318 Disp_Rti (To_Ghdl_Rtin_Block_Acc (Rti).Parent, Ctxt, Indent); 1319 Disp_Block (To_Ghdl_Rtin_Block_Acc (Rti), Ctxt, Indent); 1320 when Ghdl_Rtik_Port 1321 | Ghdl_Rtik_Signal 1322 | Ghdl_Rtik_Guard 1323 | Ghdl_Rtik_Attribute_Quiet 1324 | Ghdl_Rtik_Attribute_Stable 1325 | Ghdl_Rtik_Attribute_Transaction => 1326 Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), True, Ctxt, Indent); 1327 when Ghdl_Rtik_Generic 1328 | Ghdl_Rtik_Constant 1329 | Ghdl_Rtik_Variable 1330 | Ghdl_Rtik_Iterator 1331 | Ghdl_Rtik_File => 1332 Disp_Object (To_Ghdl_Rtin_Object_Acc (Rti), False, Ctxt, Indent); 1333 when Ghdl_Rtik_Component => 1334 Disp_Component (To_Ghdl_Rtin_Component_Acc (Rti), Indent); 1335 when Ghdl_Rtik_Attribute => 1336 Disp_Attribute (To_Ghdl_Rtin_Object_Acc (Rti), Ctxt, Indent); 1337 when Ghdl_Rtik_Instance => 1338 Disp_Instance (To_Ghdl_Rtin_Instance_Acc (Rti), Ctxt, Indent); 1339 when Ghdl_Rtik_Type_B1 1340 | Ghdl_Rtik_Type_E8 1341 | Ghdl_Rtik_Type_E32 => 1342 Disp_Type_Enum_Decl (To_Ghdl_Rtin_Type_Enum_Acc (Rti), Indent); 1343 when Ghdl_Rtik_Subtype_Scalar => 1344 Disp_Subtype_Scalar_Decl (To_Ghdl_Rtin_Subtype_Scalar_Acc (Rti), 1345 Ctxt, Indent); 1346 when Ghdl_Rtik_Type_Array => 1347 Disp_Type_Array_Decl 1348 (To_Ghdl_Rtin_Type_Array_Acc (Rti), Ctxt, Indent); 1349 when Ghdl_Rtik_Subtype_Array => 1350 Disp_Subtype_Array_Decl 1351 (To_Ghdl_Rtin_Subtype_Composite_Acc (Rti), Ctxt, Indent); 1352 when Ghdl_Rtik_Subtype_Unbounded_Array => 1353 Disp_Subtype_Unbounded_Array_Decl 1354 (To_Ghdl_Rtin_Subtype_Composite_Acc (Rti), Ctxt, Indent); 1355 when Ghdl_Rtik_Type_Access 1356 | Ghdl_Rtik_Type_File => 1357 Disp_Type_File_Or_Access 1358 (To_Ghdl_Rtin_Type_Fileacc_Acc (Rti), Ctxt, Indent); 1359 when Ghdl_Rtik_Type_Record 1360 | Ghdl_Rtik_Type_Unbounded_Record => 1361 Disp_Type_Record 1362 (To_Ghdl_Rtin_Type_Record_Acc (Rti), Ctxt, Indent); 1363 when Ghdl_Rtik_Subtype_Record 1364 | Ghdl_Rtik_Subtype_Unbounded_Record => 1365 Disp_Subtype_Record_Decl 1366 (To_Ghdl_Rtin_Subtype_Composite_Acc (Rti), Ctxt, Indent); 1367 when Ghdl_Rtik_Type_Protected => 1368 Disp_Type_Protected 1369 (To_Ghdl_Rtin_Type_Scalar_Acc (Rti), Ctxt, Indent); 1370 when Ghdl_Rtik_Psl_Cover 1371 | Ghdl_Rtik_Psl_Assume 1372 | Ghdl_Rtik_Psl_Assert => 1373 Disp_Psl_Directive (To_Ghdl_Rtin_Object_Acc (Rti), Ctxt, Indent); 1374 when Ghdl_Rtik_Psl_Endpoint => 1375 Disp_Psl_Endpoint_Directive 1376 (To_Ghdl_Rtin_Object_Acc (Rti), Ctxt, Indent); 1377 when others => 1378 Disp_Indent (Indent); 1379 Disp_Kind (Rti.Kind); 1380 Put_Line (" ? "); 1381 end case; 1382 end Disp_Rti; 1383 1384 Disp_Rti_Flag : Boolean := False; 1385 1386 procedure Disp_All 1387 is 1388 Ctxt : Rti_Context; 1389 begin 1390 if not Disp_Rti_Flag then 1391 return; 1392 end if; 1393 1394 Put ("DISP_RTI.Disp_All: "); 1395 Disp_Kind (Ghdl_Rti_Top.Common.Kind); 1396 New_Line; 1397 Ctxt := (Base => Ghdl_Rti_Top_Instance, 1398 Block => Ghdl_Rti_Top.Parent); 1399 Disp_Rti_Arr (Ghdl_Rti_Top.Nbr_Child, 1400 Ghdl_Rti_Top.Children, 1401 Ctxt, 0); 1402 Disp_Rti (Ghdl_Rti_Top.Parent, Ctxt, 0); 1403 1404 --Disp_Hierarchy; 1405 end Disp_All; 1406 1407 function Disp_Rti_Option (Opt : String) return Boolean 1408 is 1409 begin 1410 if Opt = "--dump-rti" then 1411 Disp_Rti_Flag := True; 1412 return True; 1413 else 1414 return False; 1415 end if; 1416 end Disp_Rti_Option; 1417 1418 procedure Disp_Rti_Help 1419 is 1420 procedure P (Str : String) renames Put_Line; 1421 begin 1422 P (" --dump-rti dump Run Time Information"); 1423 end Disp_Rti_Help; 1424 1425 Disp_Rti_Hooks : aliased constant Hooks_Type := 1426 (Desc => new String'("dump-rti: implement --dump-rti"), 1427 Option => Disp_Rti_Option'Access, 1428 Help => Disp_Rti_Help'Access, 1429 Init => null, 1430 Start => Disp_All'Access, 1431 Finish => null); 1432 1433 procedure Register is 1434 begin 1435 Register_Hooks (Disp_Rti_Hooks'Access); 1436 end Register; 1437 1438end Grt.Disp_Rti; 1439