1-- Display the code from the ortho debug tree. 2-- Copyright (C) 2005 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 17package body Ortho_Debug.Disp is 18 Disp_All_Types : constant Boolean := False; 19 20 package Formated_Output is 21 use Interfaces.C_Streams; 22 23 type Disp_Context is limited private; 24 25 procedure Init_Context (File : FILEs); 26 27 -- Save the current context, and create a new one. 28 procedure Push_Context (File : FILEs; Prev_Ctx : out Disp_Context); 29 30 -- Restore a previous context, saved by Push_Context. 31 procedure Pop_Context (Prev_Ctx : Disp_Context); 32 33 procedure Put (Str : String); 34 35 procedure Put_Keyword (Str : String); 36 37 procedure Put_Line (Str : String); 38 39 -- Add a tabulation. 40 -- Every new line will start at this tabulation. 41 procedure Add_Tab; 42 43 -- Removed a tabulation. 44 -- The next new line will start at the previous tabulation. 45 procedure Rem_Tab; 46 47 -- Flush the current output. 48 procedure Flush; 49 50 -- Return TRUE if the ident level is nul. 51 function Is_Top return Boolean; 52 53 procedure Put_Tab; 54 55 procedure New_Line; 56 57 procedure Put (C : Character); 58 59 procedure Put_Trim (Str : String); 60 61 procedure Set_Mark; 62 63 -- Flush to disk. Only for debugging in case of crash. 64 procedure Flush_File; 65 pragma Unreferenced (Flush_File); 66 private 67 type Disp_Context is record 68 -- File where the info are written to. 69 File : FILEs; 70 -- Line number of the line to be written. 71 Lineno : Natural; 72 -- Buffer for the current line. 73 Line : String (1 .. 256); 74 -- Number of characters currently in the line. 75 Line_Len : Natural; 76 77 -- Current tabulation. 78 Tab : Natural; 79 -- Tabulation to be used for the next line. 80 Next_Tab : Natural; 81 82 Mark : Natural; 83 end record; 84 end Formated_Output; 85 86 package body Formated_Output is 87 -- The current context. 88 Ctx : Disp_Context; 89 90 procedure Init_Context (File : FILEs) is 91 begin 92 Ctx.File := File; 93 Ctx.Lineno := 1; 94 Ctx.Line_Len := 0; 95 Ctx.Tab := 0; 96 Ctx.Next_Tab := 0; 97 Ctx.Mark := 0; 98 end Init_Context; 99 100 procedure Push_Context (File : FILEs; Prev_Ctx : out Disp_Context) 101 is 102 begin 103 Prev_Ctx := Ctx; 104 Init_Context (File); 105 end Push_Context; 106 107 -- Restore a previous context, saved by Push_Context. 108 procedure Pop_Context (Prev_Ctx : Disp_Context) is 109 begin 110 Flush; 111 Ctx := Prev_Ctx; 112 end Pop_Context; 113 114 procedure Flush 115 is 116 Status : size_t; 117 Res : int; 118 pragma Unreferenced (Status, Res); 119 begin 120 if Ctx.Line_Len > 0 then 121 Status := fwrite (Ctx.Line'Address, size_t (Ctx.Line_Len), 1, 122 Ctx.File); 123 Res := fputc (Character'Pos (ASCII.Lf), Ctx.File); 124 Ctx.Line_Len := 0; 125 end if; 126 Ctx.Mark := 0; 127 end Flush; 128 129 function Is_Top return Boolean is 130 begin 131 return Ctx.Tab = 0; 132 end Is_Top; 133 134 procedure Put_Tab 135 is 136 Tab : Natural := Ctx.Next_Tab; 137 Max_Tab : constant Natural := 40; 138 begin 139 if Tab > Max_Tab then 140 -- Limit indentation length, to limit line length. 141 Tab := Max_Tab; 142 end if; 143 144 Ctx.Line (1 .. Tab) := (others => ' '); 145 Ctx.Line_Len := Tab; 146 Ctx.Next_Tab := Ctx.Tab + 2; 147 end Put_Tab; 148 149 procedure Put (Str : String) is 150 Saved : String (1 .. 80); 151 Len : Natural; 152 begin 153 if Ctx.Line_Len + Str'Length >= 80 then 154 if Ctx.Mark > 0 then 155 Len := Ctx.Line_Len - Ctx.Mark + 1; 156 Saved (1 .. Len) := Ctx.Line (Ctx.Mark .. Ctx.Line_Len); 157 Ctx.Line_Len := Ctx.Mark - 1; 158 Flush; 159 Put_Tab; 160 Ctx.Line (Ctx.Line_Len + 1 .. Ctx.Line_Len + Len) := 161 Saved (1 .. Len); 162 Ctx.Line_Len := Ctx.Line_Len + Len; 163 else 164 Flush; 165 end if; 166 end if; 167 if Ctx.Line_Len = 0 then 168 Put_Tab; 169 end if; 170 Ctx.Line (Ctx.Line_Len + 1 .. Ctx.Line_Len + Str'Length) := Str; 171 Ctx.Line_Len := Ctx.Line_Len + Str'Length; 172 end Put; 173 174 procedure Put_Keyword (Str : String) 175 is 176 Kw : String (Str'Range); 177 begin 178 -- Convert to uppercase 179 for I in Str'Range loop 180 pragma Assert (Str (I) in 'a' .. 'z'); 181 Kw (I) := Character'Val 182 (Character'Pos ('A') 183 + Character'Pos (Str (I)) - Character'Pos ('a')); 184 end loop; 185 186 Put (Kw); 187 end Put_Keyword; 188 189 procedure Put_Trim (Str : String) is 190 begin 191 for I in Str'Range loop 192 if Str (I) /= ' ' then 193 Put (Str (I .. Str'Last)); 194 return; 195 end if; 196 end loop; 197 end Put_Trim; 198 199 procedure Put_Line (Str : String) is 200 begin 201 Put (Str); 202 Flush; 203 Ctx.Next_Tab := Ctx.Tab; 204 end Put_Line; 205 206 procedure New_Line 207 is 208 Status : int; 209 pragma Unreferenced (Status); 210 begin 211 if Ctx.Line_Len > 0 then 212 Flush; 213 else 214 Status := fputc (Character'Pos (ASCII.LF), Ctx.File); 215 end if; 216 Ctx.Next_Tab := Ctx.Tab; 217 end New_Line; 218 219 procedure Put (C : Character) 220 is 221 S : constant String (1 .. 1) := (1 => C); 222 begin 223 Put (S); 224 end Put; 225 226 -- Add a tabulation. 227 -- Every new line will start at this tabulation. 228 procedure Add_Tab is 229 begin 230 Ctx.Tab := Ctx.Tab + 2; 231 Ctx.Next_Tab := Ctx.Tab; 232 end Add_Tab; 233 234 -- Removed a tabulation. 235 -- The next new line will start at the previous tabulation. 236 procedure Rem_Tab is 237 begin 238 Ctx.Tab := Ctx.Tab - 2; 239 Ctx.Next_Tab := Ctx.Tab; 240 end Rem_Tab; 241 242 procedure Set_Mark is 243 begin 244 Ctx.Mark := Ctx.Line_Len; 245 end Set_Mark; 246 247 procedure Flush_File is 248 Status : int; 249 pragma Unreferenced (Status); 250 begin 251 Flush; 252 Status := fflush (Ctx.File); 253 end Flush_File; 254 end Formated_Output; 255 256 use Formated_Output; 257 258 procedure Init_Context (File : Interfaces.C_Streams.FILEs) is 259 begin 260 Formated_Output.Init_Context (File); 261 end Init_Context; 262 263 procedure Disp_Enode (E : O_Enode; Etype : O_Tnode); 264 procedure Disp_Lnode (Node : O_Lnode); 265 procedure Disp_Gnode (Node : O_Gnode); 266 procedure Disp_Snode (First, Last : O_Snode); 267 procedure Disp_Dnode (Decl : O_Dnode); 268 procedure Disp_Tnode (Atype : O_Tnode; Full : Boolean); 269 270 procedure Disp_Ident (Id : O_Ident) is 271 begin 272 Put (Get_String (Id)); 273 end Disp_Ident; 274 275 procedure Disp_Tnode_Name (Atype : O_Tnode) is 276 begin 277 Disp_Tnode (Atype, False); 278 end Disp_Tnode_Name; 279 280 procedure Disp_Dnode_Name (Decl : O_Dnode) is 281 begin 282 Disp_Ident (Decl.Name); 283 end Disp_Dnode_Name; 284 285 procedure Disp_Loop_Name (Stmt : O_Snode) is 286 begin 287 Put_Keyword ("loop"); 288 Put (Natural'Image (Stmt.Loop_Level)); 289 end Disp_Loop_Name; 290 291 function Get_Enode_Name (Kind : OE_Kind) return String 292 is 293 begin 294 case Kind is 295-- when OE_Boolean_Lit => 296-- return "boolean_lit"; 297-- when OE_Unsigned_Lit => 298-- return "unsigned_lit"; 299-- when OE_Signed_Lit => 300-- return "signed lit"; 301-- when OE_Float_Lit => 302-- return "float lit"; 303-- when OE_Null_Lit => 304-- return "null lit"; 305-- when OE_Enum_Lit => 306-- return "enum lit"; 307 308-- when OE_Sizeof_Lit => 309-- return "sizeof lit"; 310-- when OE_Offsetof_Lit => 311-- return "offsetof lit"; 312-- when OE_Aggregate => 313-- return "aggregate"; 314-- when OE_Aggr_Element => 315-- return "aggr_element"; 316-- when OE_Union_Aggr => 317-- return "union aggr"; 318 319 when OE_Lit => 320 return "lit"; 321 when OE_Add_Ov => 322 return "+#"; 323 when OE_Sub_Ov => 324 return "-#"; 325 when OE_Mul_Ov => 326 return "*#"; 327 when OE_Div_Ov => 328 return "/#"; 329 when OE_Rem_Ov => 330 return "rem#"; 331 when OE_Mod_Ov => 332 return "mod#"; 333 when OE_Exp_Ov => 334 return "**#"; 335 336 when OE_And => 337 return "and"; 338 when OE_Or => 339 return "or"; 340 when OE_Xor => 341 return "xor"; 342 343 when OE_Not => 344 return "not"; 345 when OE_Neg_Ov => 346 return "-"; 347 when OE_Abs_Ov => 348 return "abs"; 349 350 when OE_Eq => 351 return "="; 352 when OE_Neq => 353 return "/="; 354 when OE_Le => 355 return "<="; 356 when OE_Lt => 357 return "<"; 358 when OE_Ge => 359 return ">="; 360 when OE_Gt => 361 return ">"; 362 363 when OE_Function_Call => 364 return "function call"; 365 when OE_Convert_Ov => 366 return "convert_ov"; 367 when OE_Convert => 368 return "convert"; 369 when OE_Address => 370 return "address"; 371 when OE_Unchecked_Address => 372 return "unchecked_address"; 373-- when OE_Subprogram_Address => 374-- return "subprg_address"; 375 when OE_Alloca => 376 return "alloca"; 377 when OE_Value => 378 return "value"; 379 when OE_Nil => 380 return "??"; 381 end case; 382 end Get_Enode_Name; 383 384 function Get_Lnode_Name (Kind : OL_Kind) return String 385 is 386 begin 387 case Kind is 388 when OL_Obj => 389 return "obj"; 390 when OL_Indexed_Element => 391 return "indexed_element"; 392 when OL_Slice => 393 return "slice"; 394 when OL_Selected_Element => 395 return "selected_element"; 396 when OL_Access_Element => 397 return "access_element"; 398-- when OL_Param_Ref => 399-- return "param_ref"; 400-- when OL_Var_Ref => 401-- return "var_ref"; 402-- when OL_Const_Ref => 403-- return "const_ref"; 404 end case; 405 end Get_Lnode_Name; 406 407 pragma Unreferenced (Get_Lnode_Name); 408 409 procedure Disp_Enode_Name (Kind : OE_Kind) is 410 begin 411 Put (Get_Enode_Name (Kind)); 412 end Disp_Enode_Name; 413 414 procedure Disp_Assoc_List (Head : O_Anode) 415 is 416 El : O_Anode; 417 begin 418 El := Head; 419 Put ("("); 420 if El /= null then 421 loop 422 Disp_Enode (El.Actual, El.Formal.Dtype); 423 El := El.Next; 424 exit when El = null; 425 Put (", "); 426 end loop; 427 end if; 428 Put (")"); 429 end Disp_Assoc_List; 430 431 function Image (Lit : Integer) return String 432 is 433 S : constant String := Integer'Image (Lit); 434 begin 435 if S (1) = ' ' then 436 return S (2 .. S'Length); 437 else 438 return S; 439 end if; 440 end Image; 441 442 -- Disp STR as a literal for scalar type LIT_TYPE. 443 procedure Disp_Lit (Lit_Type : O_Tnode; Known : Boolean; Str : String) is 444 begin 445 if Known and not Disp_All_Types then 446 Put_Trim (Str); 447 else 448 Disp_Tnode_Name (Lit_Type); 449 Put ("'["); 450 Put_Trim (Str); 451 Put (']'); 452 end if; 453 end Disp_Lit; 454 455 Xdigit : constant array (0 .. 15) of Character := "0123456789abcdef"; 456 457 procedure Disp_Float_Lit 458 (Lit_Type : O_Tnode; Known : Boolean; Val : IEEE_Float_64) 459 is 460 pragma Assert (IEEE_Float_64'Machine_Radix = 2); 461 pragma Assert (IEEE_Float_64'Machine_Mantissa = 53); 462 Exp : Integer; 463 Man : Unsigned_64; 464 -- Res: sign(1) + 0x(2) + Man(53 / 3 ~= 18) + p(1) + sing(1) + exp(4) 465 Str : String (1 .. 1 + 2 + 18 + 1 + 1 + 4); 466 P : Natural; 467 Neg : Boolean; 468 begin 469 Exp := IEEE_Float_64'Exponent (Val) - 1; 470 Man := Unsigned_64 (abs (IEEE_Float_64'Fraction (Val)) * 2.0 ** 53); 471 472 -- Use decimal representation if there is no digit after the dot. 473 if Man = 0 then 474 Disp_Lit (Lit_Type, Known, "0.0"); 475 else 476 pragma Assert (Shift_Right (Man, 52) = 1); 477 478 -- Remove hidden 1. 479 Man := Man and (2**52 - 1); 480 481 -- Remove trailing hex 0. 482 while Man /= 0 and (Man rem 16) = 0 loop 483 Man := Man / 16; 484 end loop; 485 486 -- Exponent. 487 P := Str'Last; 488 if Exp < 0 then 489 Neg := True; 490 Exp := -Exp; 491 else 492 Neg := False; 493 end if; 494 loop 495 Str (P) := Xdigit (Exp rem 10); 496 P := P - 1; 497 Exp := Exp / 10; 498 exit when Exp = 0; 499 end loop; 500 if Neg then 501 Str (P) := '-'; 502 P := P - 1; 503 end if; 504 Str (P) := 'p'; 505 P := P - 1; 506 507 -- Mantissa. 508 loop 509 Str (P) := Xdigit (Natural (Man and 15)); 510 P := P - 1; 511 Man := Man / 16; 512 exit when Man = 0; 513 end loop; 514 515 P := P - 4; 516 Str (P + 1) := '0'; 517 Str (P + 2) := 'x'; 518 Str (P + 3) := '1'; 519 Str (P + 4) := '.'; 520 521 if Val < 0.0 then 522 Str (P) := '-'; 523 P := P - 1; 524 end if; 525 526 Disp_Lit (Lit_Type, Known, Str (P + 1 .. Str'Last)); 527 end if; 528 end Disp_Float_Lit; 529 530 -- Display C. If CTYPE is set, this is the known type of C. 531 procedure Disp_Cnode (C : O_Cnode; Ctype : O_Tnode) 532 is 533 Known : constant Boolean := Ctype /= O_Tnode_Null; 534 begin 535 case C.Kind is 536 when OC_Unsigned_Lit => 537 if False and then (C.U_Val >= Character'Pos(' ') 538 and C.U_Val <= Character'Pos ('~')) 539 then 540 Put ('''); 541 Put (Character'Val (C.U_Val)); 542 Put ('''); 543 else 544 Disp_Lit (C.Ctype, Known, Unsigned_64'Image (C.U_Val)); 545 end if; 546 when OC_Signed_Lit => 547 Disp_Lit (C.Ctype, Known, Integer_64'Image (C.S_Val)); 548 when OC_Float_Lit => 549 Disp_Float_Lit (C.Ctype, Known, C.F_Val); 550 when OC_Boolean_Lit => 551 -- Always disp the type of boolean literals. 552 Disp_Lit (C.Ctype, False, Get_String (C.B_Id)); 553 when OC_Null_Lit => 554 -- Always disp the type of null literals. 555 Disp_Tnode_Name (C.Ctype); 556 Put ("'["); 557 Put_Keyword ("null"); 558 Put (']'); 559 when OC_Default_Lit => 560 -- Always disp the type of default literals. 561 Disp_Tnode_Name (C.Ctype); 562 Put ("'["); 563 Put_Keyword ("default"); 564 Put (']'); 565 when OC_Enum_Lit => 566 -- Always disp the type of enum literals. 567 Disp_Lit (C.Ctype, False, Get_String (C.E_Name)); 568 when OC_Sizeof_Lit => 569 Disp_Tnode_Name (C.Ctype); 570 Put ("'sizeof ("); 571 Disp_Tnode_Name (C.S_Type); 572 Put (")"); 573 when OC_Record_Sizeof_Lit => 574 Disp_Tnode_Name (C.Ctype); 575 Put ("'record_sizeof ("); 576 Disp_Tnode_Name (C.S_Type); 577 Put (")"); 578 when OC_Alignof_Lit => 579 Disp_Tnode_Name (C.Ctype); 580 Put ("'alignof ("); 581 Disp_Tnode_Name (C.S_Type); 582 Put (")"); 583 when OC_Offsetof_Lit => 584 Disp_Tnode_Name (C.Ctype); 585 Put ("'offsetof ("); 586 Disp_Tnode_Name (C.Off_Field.Parent); 587 Put ("."); 588 Disp_Ident (C.Off_Field.Ident); 589 Put (")"); 590 when OC_Array_Aggregate => 591 declare 592 El : O_Cnode; 593 El_Type : O_Tnode; 594 begin 595 El := C.Arr_Els; 596 El_Type := Get_Array_El_Type (C.Ctype); 597 Put ('['); 598 Put_Trim (Unsigned_32'Image (C.Arr_Len)); 599 Put (']'); 600 Put ('{'); 601 if El /= null then 602 loop 603 Set_Mark; 604 Disp_Cnode (El.Aggr_Value, El_Type); 605 El := El.Aggr_Next; 606 exit when El = null; 607 Put (", "); 608 end loop; 609 end if; 610 Put ('}'); 611 end; 612 when OC_Record_Aggregate => 613 declare 614 El : O_Cnode; 615 El_Type : O_Tnode; 616 Field : O_Fnode; 617 begin 618 Put ('{'); 619 El := C.Rec_Els; 620 pragma Assert (C.Ctype.Kind = ON_Record_Type); 621 Field := C.Ctype.Rec_Elements; 622 if El /= null then 623 loop 624 Set_Mark; 625 if Disp_All_Types then 626 Put ('.'); 627 Disp_Ident (Field.Ident); 628 Put (" = "); 629 end if; 630 El_Type := Field.Ftype; 631 Field := Field.Next; 632 Disp_Cnode (El.Aggr_Value, El_Type); 633 El := El.Aggr_Next; 634 exit when El = null; 635 Put (", "); 636 end loop; 637 end if; 638 Put ('}'); 639 end; 640 when OC_Aggr_Element => 641 Disp_Cnode (C.Aggr_Value, Ctype); 642 when OC_Union_Aggr => 643 Put ('{'); 644 Put ('.'); 645 Disp_Ident (C.Uaggr_Field.Ident); 646 Put (" = "); 647 Disp_Cnode (C.Uaggr_Value, C.Uaggr_Field.Ftype); 648 Put ('}'); 649 when OC_Address => 650 Disp_Tnode_Name (C.Ctype); 651 Put ("'address ("); 652 Disp_Gnode (C.Addr_Global); 653 Put (")"); 654 when OC_Unchecked_Address => 655 Disp_Tnode_Name (C.Ctype); 656 Put ("'unchecked_address ("); 657 Disp_Gnode (C.Addr_Global); 658 Put (")"); 659 when OC_Subprogram_Address => 660 Disp_Tnode_Name (C.Ctype); 661 Put ("'subprg_addr ("); 662 Disp_Dnode_Name (C.Addr_Decl); 663 Put (")"); 664 end case; 665 end Disp_Cnode; 666 667 function Is_Neg_Neg (E : O_Enode) return Boolean 668 is 669 Lit : O_Cnode; 670 begin 671 pragma Assert (E.Kind = OE_Neg_Ov); 672 case E.Operand.Kind is 673 when OE_Neg_Ov => 674 return True; 675 when OE_Lit => 676 Lit := E.Operand.Lit; 677 case Lit.Kind is 678 when OC_Signed_Lit => 679 return Lit.S_Val < 0; 680 when OC_Float_Lit => 681 return Lit.F_Val < 0.0; 682 when others => 683 null; 684 end case; 685 when others => 686 null; 687 end case; 688 return False; 689 end Is_Neg_Neg; 690 691 -- Disp E whose expected type is ETYPE (may not be set). 692 procedure Disp_Enode (E : O_Enode; Etype : O_Tnode) is 693 begin 694 case E.Kind is 695 when OE_Lit => 696 Disp_Cnode (E.Lit, Etype); 697 when OE_Dyadic_Expr_Kind => 698 Put ("("); 699 Disp_Enode (E.Left, O_Tnode_Null); 700 Put (' '); 701 case E.Kind is 702 when OE_Rem_Ov => 703 Put_Keyword ("rem"); 704 Put ('#'); 705 when OE_Mod_Ov => 706 Put_Keyword ("mod"); 707 Put ('#'); 708 when OE_And => 709 Put_Keyword ("and"); 710 when OE_Or => 711 Put_Keyword ("or"); 712 when OE_Xor => 713 Put_Keyword ("xor"); 714 when others => 715 Disp_Enode_Name (E.Kind); 716 end case; 717 Put (' '); 718 Disp_Enode (E.Right, E.Left.Rtype); 719 Put (')'); 720 when OE_Compare_Expr_Kind => 721 Disp_Tnode_Name (E.Rtype); 722 Put ("'("); 723 Disp_Enode (E.Left, O_Tnode_Null); 724 Put (' '); 725 Disp_Enode_Name (E.Kind); 726 Put (' '); 727 Disp_Enode (E.Right, E.Left.Rtype); 728 Put (')'); 729 when OE_Monadic_Expr_Kind => 730 case E.Kind is 731 when OE_Not => 732 Put_Keyword ("not"); 733 when OE_Abs_Ov => 734 Put_Keyword ("abs"); 735 when others => 736 Disp_Enode_Name (E.Kind); 737 end case; 738 -- Don't print space after '-' unless the operand is also '-'. 739 -- (avoid to print --, which is a comment). 740 if E.Kind /= OE_Neg_Ov or else Is_Neg_Neg (E) then 741 Put (' '); 742 end if; 743 Disp_Enode (E.Operand, Etype); 744 when OE_Address => 745 Disp_Tnode_Name (E.Rtype); 746 Put ("'address ("); 747 Disp_Lnode (E.Lvalue); 748 Put (")"); 749 when OE_Unchecked_Address => 750 Disp_Tnode_Name (E.Rtype); 751 Put ("'unchecked_address ("); 752 Disp_Lnode (E.Lvalue); 753 Put (")"); 754 when OE_Convert_Ov => 755 Disp_Tnode_Name (E.Rtype); 756 Put ("'conv# ("); 757 Disp_Enode (E.Conv, O_Tnode_Null); 758 Put (')'); 759 when OE_Convert => 760 Disp_Tnode_Name (E.Rtype); 761 Put ("'conv ("); 762 Disp_Enode (E.Conv, O_Tnode_Null); 763 Put (')'); 764 when OE_Function_Call => 765 Disp_Dnode_Name (E.Func); 766 Put (' '); 767 Disp_Assoc_List (E.Assoc); 768 when OE_Alloca => 769 Disp_Tnode_Name (E.Rtype); 770 Put ("'alloca ("); 771 Disp_Enode (E.A_Size, O_Tnode_Null); 772 Put (')'); 773 when OE_Value => 774 Disp_Lnode (E.Value); 775 when OE_Nil => 776 null; 777 end case; 778 end Disp_Enode; 779 780 procedure Disp_Lnode (Node : O_Lnode) is 781 begin 782 case Node.Kind is 783 when OL_Obj => 784 Disp_Dnode_Name (Node.Obj); 785 when OL_Access_Element => 786 Disp_Enode (Node.Acc_Base, O_Tnode_Null); 787 Put ("."); 788 Put_Keyword ("all"); 789 when OL_Indexed_Element => 790 Disp_Lnode (Node.Array_Base); 791 Put ('['); 792 Disp_Enode (Node.Index, O_Tnode_Null); 793 Put (']'); 794 when OL_Slice => 795 Disp_Lnode (Node.Slice_Base); 796 Put ('['); 797 Disp_Enode (Node.Slice_Index, O_Tnode_Null); 798 Put ("...]"); 799 when OL_Selected_Element => 800 Disp_Lnode (Node.Rec_Base); 801 Put ('.'); 802 Disp_Ident (Node.Rec_El.Ident); 803 end case; 804 end Disp_Lnode; 805 806 procedure Disp_Gnode (Node : O_Gnode) is 807 begin 808 case Node.Kind is 809 when OG_Decl => 810 Disp_Dnode_Name (Node.Decl); 811 when OG_Selected_Element => 812 Disp_Gnode (Node.Rec_Base); 813 Put ('.'); 814 Disp_Ident (Node.Rec_El.Ident); 815 end case; 816 end Disp_Gnode; 817 818 procedure Disp_Fnodes (First : O_Fnode) 819 is 820 El : O_Fnode; 821 begin 822 Add_Tab; 823 El := First; 824 while El /= null loop 825 Disp_Ident (El.Ident); 826 Put (": "); 827 Disp_Tnode (El.Ftype, False); 828 Put_Line (";"); 829 El := El.Next; 830 end loop; 831 Rem_Tab; 832 end Disp_Fnodes; 833 834 procedure Disp_Tnode (Atype : O_Tnode; Full : Boolean) is 835 begin 836 if not Full and Atype.Decl /= null then 837 Disp_Ident (Atype.Decl.Name); 838 return; 839 end if; 840 case Atype.Kind is 841 when ON_Boolean_Type => 842 Put_Keyword ("boolean"); 843 Put (" {"); 844 Disp_Ident (Atype.False_N.B_Id); 845 Put (", "); 846 Disp_Ident (Atype.True_N.B_Id); 847 Put ("}"); 848 when ON_Unsigned_Type => 849 Put_Keyword ("unsigned"); 850 Put (" ("); 851 Put_Trim (Natural'Image (Atype.Int_Size)); 852 Put (")"); 853 when ON_Signed_Type => 854 Put_Keyword ("signed"); 855 Put (" ("); 856 Put_Trim (Natural'Image (Atype.Int_Size)); 857 Put (")"); 858 when ON_Float_Type => 859 Put_Keyword ("float"); 860 when ON_Enum_Type => 861 declare 862 El : O_Cnode; 863 begin 864 Put_Keyword ("enum"); 865 Put (" {"); 866 El := Atype.Literals; 867 while El /= O_Cnode_Null loop 868 Set_Mark; 869 Disp_Ident (El.E_Name); 870 if False then 871 Put (" = "); 872 Put (Image (El.E_Val)); 873 end if; 874 El := El.E_Next; 875 exit when El = O_Cnode_Null; 876 Put (", "); 877 end loop; 878 Put ("}"); 879 end; 880 when ON_Array_Type => 881 Put_Keyword ("array"); 882 Put (" ["); 883 Disp_Tnode (Atype.Index_Type, False); 884 Put ("] "); 885 Put_Keyword ("of"); 886 Put (" "); 887 Disp_Tnode (Atype.El_Type, False); 888 when ON_Access_Type => 889 Put_Keyword ("access"); 890 Put (" "); 891 if Atype.D_Type /= O_Tnode_Null then 892 Disp_Tnode (Atype.D_Type, False); 893 end if; 894 when ON_Record_Type => 895 Put_Keyword ("record"); 896 New_Line; 897 Disp_Fnodes (Atype.Rec_Elements); 898 Put_Keyword ("end"); 899 Put (" "); 900 Put_Keyword ("record"); 901 when ON_Record_Subtype => 902 Put_Keyword ("subrecord"); 903 Put (" "); 904 Disp_Tnode_Name (Atype.Subrec_Base); 905 Put ("("); 906 Disp_Fnodes (Atype.Subrec_Elements); 907 Put (")"); 908 when ON_Union_Type => 909 Put_Keyword ("union"); 910 New_Line; 911 Disp_Fnodes (Atype.Rec_Elements); 912 Put_Keyword ("end"); 913 Put (" "); 914 Put_Keyword ("union"); 915 when ON_Array_Subtype => 916 declare 917 Base : constant O_Tnode := Atype.Arr_Base; 918 begin 919 Put_Keyword ("subarray"); 920 Put (" "); 921 Disp_Tnode_Name (Base); 922 Put ("["); 923 Disp_Cnode (Atype.Length, Base.Index_Type); 924 Put ("]"); 925 if Atype.Arr_El_Type /= Base.El_Type then 926 Put (" "); 927 Put_Keyword ("of"); 928 Put (" "); 929 Disp_Tnode (Atype.Arr_El_Type, False); 930 end if; 931 end; 932 end case; 933 end Disp_Tnode; 934 935 procedure Disp_Storage_Name (Storage : O_Storage) is 936 begin 937 case Storage is 938 when O_Storage_External => 939 Put_Keyword ("external"); 940 when O_Storage_Public => 941 Put_Keyword ("public"); 942 when O_Storage_Private => 943 Put_Keyword ("private"); 944 when O_Storage_Local => 945 Put_Keyword ("local"); 946 end case; 947 end Disp_Storage_Name; 948 949 procedure Disp_Decls (Decls : O_Dnode) 950 is 951 El : O_Dnode; 952 begin 953 El := Decls; 954 while El /= null loop 955 Disp_Dnode (El); 956 El := El.Next; 957 if Is_Top then 958 -- NOTE: some declaration does not disp anything, so there may be 959 -- double new line. 960 New_Line; 961 end if; 962 end loop; 963 end Disp_Decls; 964 965 procedure Disp_Function_Decl (Decl : O_Dnode) is 966 begin 967 Disp_Storage_Name (Decl.Storage); 968 Put (" "); 969 if Decl.Dtype = null then 970 Put_Keyword ("procedure"); 971 else 972 Put_Keyword ("function"); 973 end if; 974 Put (" "); 975 Disp_Ident (Decl.Name); 976 Put_Line (" ("); 977 Add_Tab; 978 declare 979 El : O_Dnode; 980 begin 981 El := Decl.Interfaces; 982 if El /= null then 983 loop 984 Disp_Dnode (El); 985 El := El.Next; 986 exit when El = null; 987 Put_Line (";"); 988 end loop; 989 end if; 990 Put (")"); 991 end; 992 if Decl.Dtype /= null then 993 New_Line; 994 Put_Keyword ("return"); 995 Put (" "); 996 Disp_Tnode (Decl.Dtype, False); 997 end if; 998 Rem_Tab; 999 end Disp_Function_Decl; 1000 1001 procedure Disp_Dnode (Decl : O_Dnode) is 1002 begin 1003 case Decl.Kind is 1004 when ON_Type_Decl => 1005 Put_Keyword ("type"); 1006 Put (" "); 1007 Disp_Ident (Decl.Name); 1008 Put (" "); 1009 Put_Keyword ("is"); 1010 Put (" "); 1011 if not Decl.Dtype.Uncomplete then 1012 Disp_Tnode (Decl.Dtype, True); 1013 else 1014 case Decl.Dtype.Kind is 1015 when ON_Record_Type => 1016 Put_Keyword ("record"); 1017 when ON_Access_Type => 1018 Put_Keyword ("access"); 1019 when others => 1020 raise Program_Error; 1021 end case; 1022 end if; 1023 Put_Line (";"); 1024 when ON_Completed_Type_Decl => 1025 Put_Keyword ("type"); 1026 Put (" "); 1027 Disp_Ident (Decl.Name); 1028 Put (" "); 1029 Put_Keyword ("is"); 1030 Put (" "); 1031 Disp_Tnode (Decl.Dtype, True); 1032 Put_Line (";"); 1033 when ON_Const_Decl => 1034 Disp_Storage_Name (Decl.Storage); 1035 Put (" "); 1036 Put_Keyword ("constant"); 1037 Put (" "); 1038 Disp_Ident (Decl.Name); 1039 Put (" : "); 1040 Disp_Tnode_Name (Decl.Dtype); 1041 Put_Line (";"); 1042 when ON_Init_Value => 1043 Put_Keyword ("constant"); 1044 Put (" "); 1045 Disp_Ident (Decl.Name); 1046 Put (" := "); 1047 Disp_Cnode (Decl.Value, Decl.Dtype); 1048 Put_Line (";"); 1049 when ON_Var_Decl => 1050 Disp_Storage_Name (Decl.Storage); 1051 Put (" "); 1052 Put_Keyword ("var"); 1053 Put (" "); 1054 Disp_Ident (Decl.Name); 1055 Put (" : "); 1056 Disp_Tnode_Name (Decl.Dtype); 1057 Put_Line (";"); 1058 when ON_Function_Decl => 1059 if Decl.Next = null or Decl.Next /= Decl.Func_Body then 1060 -- This is a forward/external declaration. 1061 Disp_Function_Decl (Decl); 1062 Put_Line (";"); 1063 end if; 1064 when ON_Function_Body => 1065 Disp_Function_Decl (Decl.Func_Decl); 1066 New_Line; 1067 Disp_Snode (Decl.Func_Stmt, Decl.Func_Stmt); 1068 when ON_Interface_Decl => 1069 Disp_Ident (Decl.Name); 1070 Put (": "); 1071 Disp_Tnode (Decl.Dtype, False); 1072 when ON_Debug_Line_Decl => 1073 Put_Line ("--#" & Natural'Image (Decl.Line)); 1074 when ON_Debug_Comment_Decl => 1075 Put_Line ("-- " & Decl.Comment.all); 1076 when ON_Debug_Filename_Decl => 1077 Put_Line ("--F " & Decl.Filename.all); 1078 end case; 1079 end Disp_Dnode; 1080 1081 procedure Disp_Snode (First : O_Snode; Last : O_Snode) is 1082 Stmt : O_Snode; 1083 begin 1084 Stmt := First; 1085 loop 1086 --if Stmt.Kind = ON_Elsif_Stmt or Stmt.Kind = ON_When_Stmt then 1087 -- Put_Indent (Tab - 1); 1088 --else 1089 -- Put_Indent (Tab); 1090 --end if; 1091 case Stmt.Kind is 1092 when ON_Declare_Stmt => 1093 Put_Keyword ("declare"); 1094 New_Line; 1095 Add_Tab; 1096 Disp_Decls (Stmt.Decls); 1097 Rem_Tab; 1098 Put_Keyword ("begin"); 1099 New_Line; 1100 Add_Tab; 1101 if Stmt.Stmts /= null then 1102 Disp_Snode (Stmt.Stmts, null); 1103 end if; 1104 Rem_Tab; 1105 Put_Keyword ("end"); 1106 Put_Line (";"); 1107 when ON_Assign_Stmt => 1108 Disp_Lnode (Stmt.Target); 1109 Put (" := "); 1110 Disp_Enode (Stmt.Value, Stmt.Target.Rtype); 1111 Put_Line (";"); 1112 when ON_Return_Stmt => 1113 Put_Keyword ("return"); 1114 Put (" "); 1115 if Stmt.Ret_Val /= null then 1116 Disp_Enode (Stmt.Ret_Val, O_Tnode_Null); 1117 end if; 1118 Put_Line (";"); 1119 when ON_If_Stmt => 1120 Add_Tab; 1121 Disp_Snode (Stmt.Next, Stmt.If_Last); 1122 Stmt := Stmt.If_Last; 1123 Rem_Tab; 1124 Put_Keyword ("end"); 1125 Put (" "); 1126 Put_Keyword ("if"); 1127 Put_Line (";"); 1128 when ON_Elsif_Stmt => 1129 Rem_Tab; 1130 if Stmt.Cond = null then 1131 Put_Keyword ("else"); 1132 New_Line; 1133 else 1134 if First = Stmt then 1135 Put_Keyword ("if"); 1136 else 1137 Put_Keyword ("elsif"); 1138 end if; 1139 Put (" "); 1140 Disp_Enode (Stmt.Cond, O_Tnode_Null); 1141 Put (" "); 1142 Put_Keyword ("then"); 1143 New_Line; 1144 end if; 1145 Add_Tab; 1146 when ON_Loop_Stmt => 1147 Disp_Loop_Name (Stmt); 1148 Put_Line (":"); 1149 Add_Tab; 1150 if Stmt.Loop_Last /= Stmt then 1151 -- Only if the loop is not empty. 1152 Disp_Snode (Stmt.Next, Stmt.Loop_Last); 1153 end if; 1154 Stmt := Stmt.Loop_Last; 1155 Rem_Tab; 1156 Put_Keyword ("end"); 1157 Put (" "); 1158 Put_Keyword ("loop"); 1159 Put_Line (";"); 1160 when ON_Exit_Stmt => 1161 Put_Keyword ("exit"); 1162 Put (" "); 1163 Disp_Loop_Name (Stmt.Loop_Id); 1164 Put_Line (";"); 1165 when ON_Next_Stmt => 1166 Put_Keyword ("next"); 1167 Put (" "); 1168 Disp_Loop_Name (Stmt.Loop_Id); 1169 Put_Line (";"); 1170 when ON_Case_Stmt => 1171 Put_Keyword ("case"); 1172 Put (" "); 1173 Disp_Enode (Stmt.Selector, O_Tnode_Null); 1174 Put (" "); 1175 Put_Keyword ("is"); 1176 Put_Line (""); 1177 Add_Tab; 1178 Disp_Snode (Stmt.Next, Stmt.Case_Last); 1179 Stmt := Stmt.Case_Last; 1180 Rem_Tab; 1181 Put_Keyword ("end"); 1182 Put (" "); 1183 Put_Keyword ("case"); 1184 Put_Line (";"); 1185 when ON_When_Stmt => 1186 declare 1187 Choice: O_Choice; 1188 Choice_Type : constant O_Tnode := 1189 Stmt.Branch_Parent.Selector.Rtype; 1190 begin 1191 Rem_Tab; 1192 Choice := Stmt.Choice_List; 1193 Put_Keyword ("when"); 1194 Put (" "); 1195 loop 1196 case Choice.Kind is 1197 when ON_Choice_Expr => 1198 Disp_Cnode (Choice.Expr, Choice_Type); 1199 when ON_Choice_Range => 1200 Disp_Cnode (Choice.Low, Choice_Type); 1201 Put (" ... "); 1202 Disp_Cnode (Choice.High, Choice_Type); 1203 when ON_Choice_Default => 1204 Put_Keyword ("default"); 1205 end case; 1206 Choice := Choice.Next; 1207 exit when Choice = null; 1208 Put_Line (","); 1209 Put (" "); 1210 end loop; 1211 Put_Line (" =>"); 1212 Add_Tab; 1213 end; 1214 when ON_Call_Stmt => 1215 Disp_Dnode_Name (Stmt.Proc); 1216 Put (' '); 1217 Disp_Assoc_List (Stmt.Assoc); 1218 Put_Line (";"); 1219 when ON_Debug_Line_Stmt => 1220 Put_Line ("--#" & Natural'Image (Stmt.Line)); 1221 when ON_Debug_Comment_Stmt => 1222 Put_Line ("-- " & Stmt.Comment.all); 1223 end case; 1224 exit when Stmt = Last; 1225 Stmt := Stmt.Next; 1226 exit when Stmt = null and Last = null; 1227 end loop; 1228 end Disp_Snode; 1229 1230 procedure Disp_Ortho (Decls : O_Snode) is 1231 begin 1232 Disp_Decls (Decls.Decls); 1233 Flush; 1234 end Disp_Ortho; 1235 1236 procedure Disp_Tnode_Decl (N : O_Tnode) is 1237 begin 1238 if N.Decl /= O_Dnode_Null then 1239 Disp_Ident (N.Decl.Name); 1240 Put (" : "); 1241 end if; 1242 Disp_Tnode (N, True); 1243 end Disp_Tnode_Decl; 1244 1245 procedure Debug_Tnode (N : O_Tnode) 1246 is 1247 Ctx : Disp_Context; 1248 begin 1249 Push_Context (Interfaces.C_Streams.stdout, Ctx); 1250 Disp_Tnode_Decl (N); 1251 Pop_Context (Ctx); 1252 end Debug_Tnode; 1253 1254 procedure Debug_Enode (N : O_Enode) 1255 is 1256 Ctx : Disp_Context; 1257 begin 1258 Push_Context (Interfaces.C_Streams.stdout, Ctx); 1259 Disp_Enode (N, O_Tnode_Null); 1260 Put (" : "); 1261 Disp_Tnode_Decl (N.Rtype); 1262 Pop_Context (Ctx); 1263 end Debug_Enode; 1264 1265 procedure Debug_Fnode (N : O_Fnode) 1266 is 1267 Ctx : Disp_Context; 1268 begin 1269 Push_Context (Interfaces.C_Streams.stdout, Ctx); 1270 Disp_Ident (N.Ident); 1271 Put (": "); 1272 Disp_Tnode (N.Ftype, False); 1273 Pop_Context (Ctx); 1274 end Debug_Fnode; 1275 1276 procedure Debug_Dnode (N : O_Dnode) 1277 is 1278 Ctx : Disp_Context; 1279 begin 1280 Push_Context (Interfaces.C_Streams.stdout, Ctx); 1281 Disp_Dnode (N); 1282 Pop_Context (Ctx); 1283 end Debug_Dnode; 1284 1285 procedure Debug_Lnode (N : O_Lnode) 1286 is 1287 Ctx : Disp_Context; 1288 begin 1289 Push_Context (Interfaces.C_Streams.stdout, Ctx); 1290 Disp_Lnode (N); 1291 Put (" : "); 1292 Disp_Tnode_Decl (N.Rtype); 1293 Pop_Context (Ctx); 1294 end Debug_Lnode; 1295 1296 procedure Debug_Snode (N : O_Snode) 1297 is 1298 Ctx : Disp_Context; 1299 begin 1300 Push_Context (Interfaces.C_Streams.stdout, Ctx); 1301 Disp_Snode (N, null); 1302 Pop_Context (Ctx); 1303 end Debug_Snode; 1304 1305 pragma Unreferenced (Debug_Tnode, Debug_Enode, Debug_Fnode, 1306 Debug_Dnode, Debug_Lnode, Debug_Snode); 1307end Ortho_Debug.Disp; 1308