1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- R E P I N F O -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1999-2018, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with Alloc; 33with Atree; use Atree; 34with Casing; use Casing; 35with Debug; use Debug; 36with Einfo; use Einfo; 37with Lib; use Lib; 38with Namet; use Namet; 39with Nlists; use Nlists; 40with Opt; use Opt; 41with Output; use Output; 42with Sem_Aux; use Sem_Aux; 43with Sinfo; use Sinfo; 44with Sinput; use Sinput; 45with Snames; use Snames; 46with Stand; use Stand; 47with Stringt; use Stringt; 48with Table; 49with Uname; use Uname; 50with Urealp; use Urealp; 51 52with Ada.Unchecked_Conversion; 53 54package body Repinfo is 55 56 SSU : constant := 8; 57 -- Value for Storage_Unit, we do not want to get this from TTypes, since 58 -- this introduces problematic dependencies in ASIS, and in any case this 59 -- value is assumed to be 8 for the implementation of the DDA. 60 61 --------------------------------------- 62 -- Representation of GCC Expressions -- 63 --------------------------------------- 64 65 -- A table internal to this unit is used to hold the values of back 66 -- annotated expressions. This table is written out by -gnatt and read 67 -- back in for ASIS processing. 68 69 -- Node values are stored as Uint values using the negative of the node 70 -- index in this table. Constants appear as non-negative Uint values. 71 72 type Exp_Node is record 73 Expr : TCode; 74 Op1 : Node_Ref_Or_Val; 75 Op2 : Node_Ref_Or_Val; 76 Op3 : Node_Ref_Or_Val; 77 end record; 78 79 -- The following representation clause ensures that the above record 80 -- has no holes. We do this so that when instances of this record are 81 -- written by Tree_Gen, we do not write uninitialized values to the file. 82 83 for Exp_Node use record 84 Expr at 0 range 0 .. 31; 85 Op1 at 4 range 0 .. 31; 86 Op2 at 8 range 0 .. 31; 87 Op3 at 12 range 0 .. 31; 88 end record; 89 90 for Exp_Node'Size use 16 * 8; 91 -- This ensures that we did not leave out any fields 92 93 package Rep_Table is new Table.Table ( 94 Table_Component_Type => Exp_Node, 95 Table_Index_Type => Nat, 96 Table_Low_Bound => 1, 97 Table_Initial => Alloc.Rep_Table_Initial, 98 Table_Increment => Alloc.Rep_Table_Increment, 99 Table_Name => "BE_Rep_Table"); 100 101 -------------------------------------------------------------- 102 -- Representation of Front-End Dynamic Size/Offset Entities -- 103 -------------------------------------------------------------- 104 105 package Dynamic_SO_Entity_Table is new Table.Table ( 106 Table_Component_Type => Entity_Id, 107 Table_Index_Type => Nat, 108 Table_Low_Bound => 1, 109 Table_Initial => Alloc.Rep_Table_Initial, 110 Table_Increment => Alloc.Rep_Table_Increment, 111 Table_Name => "FE_Rep_Table"); 112 113 Unit_Casing : Casing_Type; 114 -- Identifier casing for current unit. This is set by List_Rep_Info for 115 -- each unit, before calling subprograms which may read it. 116 117 Need_Blank_Line : Boolean; 118 -- Set True if a blank line is needed before outputting any information for 119 -- the current entity. Set True when a new entity is processed, and false 120 -- when the blank line is output. 121 122 ----------------------- 123 -- Local Subprograms -- 124 ----------------------- 125 126 function Back_End_Layout return Boolean; 127 -- Test for layout mode, True = back end, False = front end. This function 128 -- is used rather than checking the configuration parameter because we do 129 -- not want Repinfo to depend on Targparm (for ASIS) 130 131 procedure Blank_Line; 132 -- Called before outputting anything for an entity. Ensures that 133 -- a blank line precedes the output for a particular entity. 134 135 procedure List_Entities 136 (Ent : Entity_Id; 137 Bytes_Big_Endian : Boolean; 138 In_Subprogram : Boolean := False); 139 -- This procedure lists the entities associated with the entity E, starting 140 -- with the First_Entity and using the Next_Entity link. If a nested 141 -- package is found, entities within the package are recursively processed. 142 -- When recursing within a subprogram body, Is_Subprogram suppresses 143 -- duplicate information about signature. 144 145 procedure List_Name (Ent : Entity_Id); 146 -- List name of entity Ent in appropriate case. The name is listed with 147 -- full qualification up to but not including the compilation unit name. 148 149 procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean); 150 -- List representation info for array type Ent 151 152 procedure List_Linker_Section (Ent : Entity_Id); 153 -- List linker section for Ent (caller has checked that Ent is an entity 154 -- for which the Linker_Section_Pragma field is defined). 155 156 procedure List_Mechanisms (Ent : Entity_Id); 157 -- List mechanism information for parameters of Ent, which is subprogram, 158 -- subprogram type, or an entry or entry family. 159 160 procedure List_Object_Info (Ent : Entity_Id); 161 -- List representation info for object Ent 162 163 procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean); 164 -- List representation info for record type Ent 165 166 procedure List_Scalar_Storage_Order 167 (Ent : Entity_Id; 168 Bytes_Big_Endian : Boolean); 169 -- List scalar storage order information for record or array type Ent. 170 -- Also includes bit order information for record types, if necessary. 171 172 procedure List_Type_Info (Ent : Entity_Id); 173 -- List type info for type Ent 174 175 function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean; 176 -- Returns True if Val represents a variable value, and False if it 177 -- represents a value that is fixed at compile time. 178 179 procedure Spaces (N : Natural); 180 -- Output given number of spaces 181 182 procedure Write_Info_Line (S : String); 183 -- Routine to write a line to Repinfo output file. This routine is passed 184 -- as a special output procedure to Output.Set_Special_Output. Note that 185 -- Write_Info_Line is called with an EOL character at the end of each line, 186 -- as per the Output spec, but the internal call to the appropriate routine 187 -- in Osint requires that the end of line sequence be stripped off. 188 189 procedure Write_Mechanism (M : Mechanism_Type); 190 -- Writes symbolic string for mechanism represented by M 191 192 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False); 193 -- Given a representation value, write it out. No_Uint values or values 194 -- dependent on discriminants are written as two question marks. If the 195 -- flag Paren is set, then the output is surrounded in parentheses if it is 196 -- other than a simple value. 197 198 --------------------- 199 -- Back_End_Layout -- 200 --------------------- 201 202 function Back_End_Layout return Boolean is 203 begin 204 -- We have back end layout if the back end has made any entries in the 205 -- table of GCC expressions, otherwise we have front end layout. 206 207 return Rep_Table.Last > 0; 208 end Back_End_Layout; 209 210 ---------------- 211 -- Blank_Line -- 212 ---------------- 213 214 procedure Blank_Line is 215 begin 216 if Need_Blank_Line then 217 Write_Eol; 218 Need_Blank_Line := False; 219 end if; 220 end Blank_Line; 221 222 ------------------------ 223 -- Create_Discrim_Ref -- 224 ------------------------ 225 226 function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref is 227 begin 228 return Create_Node 229 (Expr => Discrim_Val, 230 Op1 => Discriminant_Number (Discr)); 231 end Create_Discrim_Ref; 232 233 --------------------------- 234 -- Create_Dynamic_SO_Ref -- 235 --------------------------- 236 237 function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref is 238 begin 239 Dynamic_SO_Entity_Table.Append (E); 240 return UI_From_Int (-Dynamic_SO_Entity_Table.Last); 241 end Create_Dynamic_SO_Ref; 242 243 ----------------- 244 -- Create_Node -- 245 ----------------- 246 247 function Create_Node 248 (Expr : TCode; 249 Op1 : Node_Ref_Or_Val; 250 Op2 : Node_Ref_Or_Val := No_Uint; 251 Op3 : Node_Ref_Or_Val := No_Uint) return Node_Ref 252 is 253 begin 254 Rep_Table.Append ( 255 (Expr => Expr, 256 Op1 => Op1, 257 Op2 => Op2, 258 Op3 => Op3)); 259 return UI_From_Int (-Rep_Table.Last); 260 end Create_Node; 261 262 --------------------------- 263 -- Get_Dynamic_SO_Entity -- 264 --------------------------- 265 266 function Get_Dynamic_SO_Entity (U : Dynamic_SO_Ref) return Entity_Id is 267 begin 268 return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U)); 269 end Get_Dynamic_SO_Entity; 270 271 ----------------------- 272 -- Is_Dynamic_SO_Ref -- 273 ----------------------- 274 275 function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is 276 begin 277 return U < Uint_0; 278 end Is_Dynamic_SO_Ref; 279 280 ---------------------- 281 -- Is_Static_SO_Ref -- 282 ---------------------- 283 284 function Is_Static_SO_Ref (U : SO_Ref) return Boolean is 285 begin 286 return U >= Uint_0; 287 end Is_Static_SO_Ref; 288 289 --------- 290 -- lgx -- 291 --------- 292 293 procedure lgx (U : Node_Ref_Or_Val) is 294 begin 295 List_GCC_Expression (U); 296 Write_Eol; 297 end lgx; 298 299 ---------------------- 300 -- List_Array_Info -- 301 ---------------------- 302 303 procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is 304 begin 305 List_Type_Info (Ent); 306 Write_Str ("for "); 307 List_Name (Ent); 308 Write_Str ("'Component_Size use "); 309 Write_Val (Component_Size (Ent)); 310 Write_Line (";"); 311 312 List_Scalar_Storage_Order (Ent, Bytes_Big_Endian); 313 end List_Array_Info; 314 315 ------------------- 316 -- List_Entities -- 317 ------------------- 318 319 procedure List_Entities 320 (Ent : Entity_Id; 321 Bytes_Big_Endian : Boolean; 322 In_Subprogram : Boolean := False) 323 is 324 Body_E : Entity_Id; 325 E : Entity_Id; 326 327 function Find_Declaration (E : Entity_Id) return Node_Id; 328 -- Utility to retrieve declaration node for entity in the 329 -- case of package bodies and subprograms. 330 331 ---------------------- 332 -- Find_Declaration -- 333 ---------------------- 334 335 function Find_Declaration (E : Entity_Id) return Node_Id is 336 Decl : Node_Id; 337 338 begin 339 Decl := Parent (E); 340 while Present (Decl) 341 and then Nkind (Decl) /= N_Package_Body 342 and then Nkind (Decl) /= N_Subprogram_Declaration 343 and then Nkind (Decl) /= N_Subprogram_Body 344 loop 345 Decl := Parent (Decl); 346 end loop; 347 348 return Decl; 349 end Find_Declaration; 350 351 -- Start of processing for List_Entities 352 353 begin 354 -- List entity if we have one, and it is not a renaming declaration. 355 -- For renamings, we don't get proper information, and really it makes 356 -- sense to restrict the output to the renamed entity. 357 358 if Present (Ent) 359 and then Nkind (Declaration_Node (Ent)) not in N_Renaming_Declaration 360 then 361 -- If entity is a subprogram and we are listing mechanisms, 362 -- then we need to list mechanisms for this entity. We skip this 363 -- if it is a nested subprogram, as the information has already 364 -- been produced when listing the enclosing scope. 365 366 if List_Representation_Info_Mechanisms 367 and then (Is_Subprogram (Ent) 368 or else Ekind (Ent) = E_Entry 369 or else Ekind (Ent) = E_Entry_Family) 370 and then not In_Subprogram 371 then 372 Need_Blank_Line := True; 373 List_Mechanisms (Ent); 374 end if; 375 376 E := First_Entity (Ent); 377 while Present (E) loop 378 Need_Blank_Line := True; 379 380 -- We list entities that come from source (excluding private or 381 -- incomplete types or deferred constants, where we will list the 382 -- info for the full view). If debug flag A is set, then all 383 -- entities are listed 384 385 if (Comes_From_Source (E) 386 and then not Is_Incomplete_Or_Private_Type (E) 387 and then not (Ekind (E) = E_Constant 388 and then Present (Full_View (E)))) 389 or else Debug_Flag_AA 390 then 391 if Is_Subprogram (E) then 392 List_Linker_Section (E); 393 394 if List_Representation_Info_Mechanisms then 395 List_Mechanisms (E); 396 end if; 397 398 -- Recurse into entities local to subprogram 399 400 List_Entities (E, Bytes_Big_Endian, True); 401 402 elsif Ekind (E) in Formal_Kind and then In_Subprogram then 403 null; 404 405 elsif Ekind_In (E, E_Entry, 406 E_Entry_Family, 407 E_Subprogram_Type) 408 then 409 if List_Representation_Info_Mechanisms then 410 List_Mechanisms (E); 411 end if; 412 413 elsif Is_Record_Type (E) then 414 if List_Representation_Info >= 1 then 415 List_Record_Info (E, Bytes_Big_Endian); 416 end if; 417 418 List_Linker_Section (E); 419 420 elsif Is_Array_Type (E) then 421 if List_Representation_Info >= 1 then 422 List_Array_Info (E, Bytes_Big_Endian); 423 end if; 424 425 List_Linker_Section (E); 426 427 elsif Is_Type (E) then 428 if List_Representation_Info >= 2 then 429 List_Type_Info (E); 430 List_Linker_Section (E); 431 end if; 432 433 elsif Ekind_In (E, E_Variable, E_Constant) then 434 if List_Representation_Info >= 2 then 435 List_Object_Info (E); 436 List_Linker_Section (E); 437 end if; 438 439 elsif Ekind (E) = E_Loop_Parameter or else Is_Formal (E) then 440 if List_Representation_Info >= 2 then 441 List_Object_Info (E); 442 end if; 443 end if; 444 445 -- Recurse into nested package, but not if they are package 446 -- renamings (in particular renamings of the enclosing package, 447 -- as for some Java bindings and for generic instances). 448 449 if Ekind (E) = E_Package then 450 if No (Renamed_Object (E)) then 451 List_Entities (E, Bytes_Big_Endian); 452 end if; 453 454 -- Recurse into bodies 455 456 elsif Ekind_In (E, E_Protected_Type, 457 E_Task_Type, 458 E_Subprogram_Body, 459 E_Package_Body, 460 E_Task_Body, 461 E_Protected_Body) 462 then 463 List_Entities (E, Bytes_Big_Endian); 464 465 -- Recurse into blocks 466 467 elsif Ekind (E) = E_Block then 468 List_Entities (E, Bytes_Big_Endian); 469 end if; 470 end if; 471 472 E := Next_Entity (E); 473 end loop; 474 475 -- For a package body, the entities of the visible subprograms are 476 -- declared in the corresponding spec. Iterate over its entities in 477 -- order to handle properly the subprogram bodies. Skip bodies in 478 -- subunits, which are listed independently. 479 480 if Ekind (Ent) = E_Package_Body 481 and then Present (Corresponding_Spec (Find_Declaration (Ent))) 482 then 483 E := First_Entity (Corresponding_Spec (Find_Declaration (Ent))); 484 while Present (E) loop 485 if Is_Subprogram (E) 486 and then 487 Nkind (Find_Declaration (E)) = N_Subprogram_Declaration 488 then 489 Body_E := Corresponding_Body (Find_Declaration (E)); 490 491 if Present (Body_E) 492 and then 493 Nkind (Parent (Find_Declaration (Body_E))) /= N_Subunit 494 then 495 List_Entities (Body_E, Bytes_Big_Endian); 496 end if; 497 end if; 498 499 Next_Entity (E); 500 end loop; 501 end if; 502 end if; 503 end List_Entities; 504 505 ------------------------- 506 -- List_GCC_Expression -- 507 ------------------------- 508 509 procedure List_GCC_Expression (U : Node_Ref_Or_Val) is 510 511 procedure Print_Expr (Val : Node_Ref_Or_Val); 512 -- Internal recursive procedure to print expression 513 514 ---------------- 515 -- Print_Expr -- 516 ---------------- 517 518 procedure Print_Expr (Val : Node_Ref_Or_Val) is 519 begin 520 if Val >= 0 then 521 UI_Write (Val, Decimal); 522 523 else 524 declare 525 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val)); 526 527 procedure Binop (S : String); 528 -- Output text for binary operator with S being operator name 529 530 ----------- 531 -- Binop -- 532 ----------- 533 534 procedure Binop (S : String) is 535 begin 536 Write_Char ('('); 537 Print_Expr (Node.Op1); 538 Write_Str (S); 539 Print_Expr (Node.Op2); 540 Write_Char (')'); 541 end Binop; 542 543 -- Start of processing for Print_Expr 544 545 begin 546 case Node.Expr is 547 when Cond_Expr => 548 Write_Str ("(if "); 549 Print_Expr (Node.Op1); 550 Write_Str (" then "); 551 Print_Expr (Node.Op2); 552 Write_Str (" else "); 553 Print_Expr (Node.Op3); 554 Write_Str (" end)"); 555 556 when Plus_Expr => 557 Binop (" + "); 558 559 when Minus_Expr => 560 Binop (" - "); 561 562 when Mult_Expr => 563 Binop (" * "); 564 565 when Trunc_Div_Expr => 566 Binop (" /t "); 567 568 when Ceil_Div_Expr => 569 Binop (" /c "); 570 571 when Floor_Div_Expr => 572 Binop (" /f "); 573 574 when Trunc_Mod_Expr => 575 Binop (" modt "); 576 577 when Floor_Mod_Expr => 578 Binop (" modf "); 579 580 when Ceil_Mod_Expr => 581 Binop (" modc "); 582 583 when Exact_Div_Expr => 584 Binop (" /e "); 585 586 when Negate_Expr => 587 Write_Char ('-'); 588 Print_Expr (Node.Op1); 589 590 when Min_Expr => 591 Binop (" min "); 592 593 when Max_Expr => 594 Binop (" max "); 595 596 when Abs_Expr => 597 Write_Str ("abs "); 598 Print_Expr (Node.Op1); 599 600 when Truth_Andif_Expr => 601 Binop (" and if "); 602 603 when Truth_Orif_Expr => 604 Binop (" or if "); 605 606 when Truth_And_Expr => 607 Binop (" and "); 608 609 when Truth_Or_Expr => 610 Binop (" or "); 611 612 when Truth_Xor_Expr => 613 Binop (" xor "); 614 615 when Truth_Not_Expr => 616 Write_Str ("not "); 617 Print_Expr (Node.Op1); 618 619 when Bit_And_Expr => 620 Binop (" & "); 621 622 when Lt_Expr => 623 Binop (" < "); 624 625 when Le_Expr => 626 Binop (" <= "); 627 628 when Gt_Expr => 629 Binop (" > "); 630 631 when Ge_Expr => 632 Binop (" >= "); 633 634 when Eq_Expr => 635 Binop (" == "); 636 637 when Ne_Expr => 638 Binop (" != "); 639 640 when Discrim_Val => 641 Write_Char ('#'); 642 UI_Write (Node.Op1); 643 644 when Dynamic_Val => 645 Write_Str ("Var"); 646 UI_Write (Node.Op1); 647 end case; 648 end; 649 end if; 650 end Print_Expr; 651 652 -- Start of processing for List_GCC_Expression 653 654 begin 655 if U = No_Uint then 656 Write_Str ("??"); 657 else 658 Print_Expr (U); 659 end if; 660 end List_GCC_Expression; 661 662 ------------------------- 663 -- List_Linker_Section -- 664 ------------------------- 665 666 procedure List_Linker_Section (Ent : Entity_Id) is 667 Arg : Node_Id; 668 669 begin 670 if Present (Linker_Section_Pragma (Ent)) then 671 Write_Str ("pragma Linker_Section ("); 672 List_Name (Ent); 673 Write_Str (", """); 674 675 Arg := 676 Last (Pragma_Argument_Associations (Linker_Section_Pragma (Ent))); 677 678 if Nkind (Arg) = N_Pragma_Argument_Association then 679 Arg := Expression (Arg); 680 end if; 681 682 pragma Assert (Nkind (Arg) = N_String_Literal); 683 String_To_Name_Buffer (Strval (Arg)); 684 Write_Str (Name_Buffer (1 .. Name_Len)); 685 Write_Str (""");"); 686 Write_Eol; 687 end if; 688 end List_Linker_Section; 689 690 --------------------- 691 -- List_Mechanisms -- 692 --------------------- 693 694 procedure List_Mechanisms (Ent : Entity_Id) is 695 Plen : Natural; 696 Form : Entity_Id; 697 698 begin 699 Blank_Line; 700 701 case Ekind (Ent) is 702 when E_Function => 703 Write_Str ("function "); 704 705 when E_Operator => 706 Write_Str ("operator "); 707 708 when E_Procedure => 709 Write_Str ("procedure "); 710 711 when E_Subprogram_Type => 712 Write_Str ("type "); 713 714 when E_Entry 715 | E_Entry_Family 716 => 717 Write_Str ("entry "); 718 719 when others => 720 raise Program_Error; 721 end case; 722 723 Get_Unqualified_Decoded_Name_String (Chars (Ent)); 724 Write_Str (Name_Buffer (1 .. Name_Len)); 725 Write_Str (" declared at "); 726 Write_Location (Sloc (Ent)); 727 Write_Eol; 728 729 Write_Str (" convention : "); 730 731 case Convention (Ent) is 732 when Convention_Ada => 733 Write_Line ("Ada"); 734 735 when Convention_Ada_Pass_By_Copy => 736 Write_Line ("Ada_Pass_By_Copy"); 737 738 when Convention_Ada_Pass_By_Reference => 739 Write_Line ("Ada_Pass_By_Reference"); 740 741 when Convention_Intrinsic => 742 Write_Line ("Intrinsic"); 743 744 when Convention_Entry => 745 Write_Line ("Entry"); 746 747 when Convention_Protected => 748 Write_Line ("Protected"); 749 750 when Convention_Assembler => 751 Write_Line ("Assembler"); 752 753 when Convention_C => 754 Write_Line ("C"); 755 756 when Convention_COBOL => 757 Write_Line ("COBOL"); 758 759 when Convention_CPP => 760 Write_Line ("C++"); 761 762 when Convention_Fortran => 763 Write_Line ("Fortran"); 764 765 when Convention_Stdcall => 766 Write_Line ("Stdcall"); 767 768 when Convention_Stubbed => 769 Write_Line ("Stubbed"); 770 end case; 771 772 -- Find max length of formal name 773 774 Plen := 0; 775 Form := First_Formal (Ent); 776 while Present (Form) loop 777 Get_Unqualified_Decoded_Name_String (Chars (Form)); 778 779 if Name_Len > Plen then 780 Plen := Name_Len; 781 end if; 782 783 Next_Formal (Form); 784 end loop; 785 786 -- Output formals and mechanisms 787 788 Form := First_Formal (Ent); 789 while Present (Form) loop 790 Get_Unqualified_Decoded_Name_String (Chars (Form)); 791 while Name_Len <= Plen loop 792 Name_Len := Name_Len + 1; 793 Name_Buffer (Name_Len) := ' '; 794 end loop; 795 796 Write_Str (" "); 797 Write_Str (Name_Buffer (1 .. Plen + 1)); 798 Write_Str (": passed by "); 799 800 Write_Mechanism (Mechanism (Form)); 801 Write_Eol; 802 Next_Formal (Form); 803 end loop; 804 805 if Etype (Ent) /= Standard_Void_Type then 806 Write_Str (" returns by "); 807 Write_Mechanism (Mechanism (Ent)); 808 Write_Eol; 809 end if; 810 end List_Mechanisms; 811 812 --------------- 813 -- List_Name -- 814 --------------- 815 816 procedure List_Name (Ent : Entity_Id) is 817 begin 818 if not Is_Compilation_Unit (Scope (Ent)) then 819 List_Name (Scope (Ent)); 820 Write_Char ('.'); 821 end if; 822 823 Get_Unqualified_Decoded_Name_String (Chars (Ent)); 824 Set_Casing (Unit_Casing); 825 Write_Str (Name_Buffer (1 .. Name_Len)); 826 end List_Name; 827 828 --------------------- 829 -- List_Object_Info -- 830 --------------------- 831 832 procedure List_Object_Info (Ent : Entity_Id) is 833 begin 834 Blank_Line; 835 836 Write_Str ("for "); 837 List_Name (Ent); 838 Write_Str ("'Size use "); 839 Write_Val (Esize (Ent)); 840 Write_Line (";"); 841 842 Write_Str ("for "); 843 List_Name (Ent); 844 Write_Str ("'Alignment use "); 845 Write_Val (Alignment (Ent)); 846 Write_Line (";"); 847 end List_Object_Info; 848 849 ---------------------- 850 -- List_Record_Info -- 851 ---------------------- 852 853 procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is 854 procedure Compute_Max_Length 855 (Ent : Entity_Id; 856 Starting_Position : Uint := Uint_0; 857 Starting_First_Bit : Uint := Uint_0; 858 Prefix_Length : Natural := 0); 859 -- Internal recursive procedure to compute the max length 860 861 procedure List_Record_Layout 862 (Ent : Entity_Id; 863 Starting_Position : Uint := Uint_0; 864 Starting_First_Bit : Uint := Uint_0; 865 Prefix : String := ""); 866 -- Internal recursive procedure to display the layout 867 868 Max_Name_Length : Natural := 0; 869 Max_Spos_Length : Natural := 0; 870 871 ------------------------ 872 -- Compute_Max_Length -- 873 ------------------------ 874 875 procedure Compute_Max_Length 876 (Ent : Entity_Id; 877 Starting_Position : Uint := Uint_0; 878 Starting_First_Bit : Uint := Uint_0; 879 Prefix_Length : Natural := 0) 880 is 881 Comp : Entity_Id; 882 883 begin 884 Comp := First_Component_Or_Discriminant (Ent); 885 while Present (Comp) loop 886 887 -- Skip discriminant in unchecked union (since it is not there!) 888 889 if Ekind (Comp) = E_Discriminant 890 and then Is_Unchecked_Union (Ent) 891 then 892 goto Continue; 893 end if; 894 895 -- All other cases 896 897 declare 898 Ctyp : constant Entity_Id := Underlying_Type (Etype (Comp)); 899 Bofs : constant Uint := Component_Bit_Offset (Comp); 900 Npos : Uint; 901 Fbit : Uint; 902 Spos : Uint; 903 Sbit : Uint; 904 905 Name_Length : Natural; 906 907 begin 908 Get_Decoded_Name_String (Chars (Comp)); 909 Name_Length := Prefix_Length + Name_Len; 910 911 if Rep_Not_Constant (Bofs) then 912 913 -- If the record is not packed, then we know that all fields 914 -- whose position is not specified have starting normalized 915 -- bit position of zero. 916 917 if Unknown_Normalized_First_Bit (Comp) 918 and then not Is_Packed (Ent) 919 then 920 Set_Normalized_First_Bit (Comp, Uint_0); 921 end if; 922 923 UI_Image_Length := 2; -- For "??" marker 924 else 925 Npos := Bofs / SSU; 926 Fbit := Bofs mod SSU; 927 928 -- Complete annotation in case not done 929 930 if Unknown_Normalized_First_Bit (Comp) then 931 Set_Normalized_Position (Comp, Npos); 932 Set_Normalized_First_Bit (Comp, Fbit); 933 end if; 934 935 Spos := Starting_Position + Npos; 936 Sbit := Starting_First_Bit + Fbit; 937 938 if Sbit >= SSU then 939 Spos := Spos + 1; 940 Sbit := Sbit - SSU; 941 end if; 942 943 -- If extended information is requested, recurse fully into 944 -- record components, i.e. skip the outer level. 945 946 if List_Representation_Info_Extended 947 and then Is_Record_Type (Ctyp) 948 then 949 Compute_Max_Length (Ctyp, Spos, Sbit, Name_Length + 1); 950 goto Continue; 951 end if; 952 953 UI_Image (Spos); 954 end if; 955 956 Max_Name_Length := Natural'Max (Max_Name_Length, Name_Length); 957 Max_Spos_Length := 958 Natural'Max (Max_Spos_Length, UI_Image_Length); 959 end; 960 961 <<Continue>> 962 Next_Component_Or_Discriminant (Comp); 963 end loop; 964 end Compute_Max_Length; 965 966 ------------------------ 967 -- List_Record_Layout -- 968 ------------------------ 969 970 procedure List_Record_Layout 971 (Ent : Entity_Id; 972 Starting_Position : Uint := Uint_0; 973 Starting_First_Bit : Uint := Uint_0; 974 Prefix : String := "") 975 is 976 Comp : Entity_Id; 977 978 begin 979 Comp := First_Component_Or_Discriminant (Ent); 980 while Present (Comp) loop 981 982 -- Skip discriminant in unchecked union (since it is not there!) 983 984 if Ekind (Comp) = E_Discriminant 985 and then Is_Unchecked_Union (Ent) 986 then 987 goto Continue; 988 end if; 989 990 -- All other cases 991 992 declare 993 Ctyp : constant Entity_Id := Underlying_Type (Etype (Comp)); 994 Esiz : constant Uint := Esize (Comp); 995 Bofs : constant Uint := Component_Bit_Offset (Comp); 996 Npos : constant Uint := Normalized_Position (Comp); 997 Fbit : constant Uint := Normalized_First_Bit (Comp); 998 Spos : Uint; 999 Sbit : Uint; 1000 Lbit : Uint; 1001 1002 begin 1003 Get_Decoded_Name_String (Chars (Comp)); 1004 Set_Casing (Unit_Casing); 1005 1006 -- If extended information is requested, recurse fully into 1007 -- record components, i.e. skip the outer level. 1008 1009 if List_Representation_Info_Extended 1010 and then Is_Record_Type (Ctyp) 1011 and then Known_Static_Normalized_Position (Comp) 1012 and then Known_Static_Normalized_First_Bit (Comp) 1013 then 1014 Spos := Starting_Position + Npos; 1015 Sbit := Starting_First_Bit + Fbit; 1016 1017 if Sbit >= SSU then 1018 Spos := Spos + 1; 1019 Sbit := Sbit - SSU; 1020 end if; 1021 1022 List_Record_Layout (Ctyp, 1023 Spos, Sbit, Prefix & Name_Buffer (1 .. Name_Len) & "."); 1024 1025 goto Continue; 1026 end if; 1027 1028 Write_Str (" "); 1029 Write_Str (Prefix); 1030 Write_Str (Name_Buffer (1 .. Name_Len)); 1031 1032 for J in 1 .. Max_Name_Length - Prefix'Length - Name_Len loop 1033 Write_Char (' '); 1034 end loop; 1035 1036 Write_Str (" at "); 1037 1038 if Known_Static_Normalized_Position (Comp) then 1039 Spos := Starting_Position + Npos; 1040 Sbit := Starting_First_Bit + Fbit; 1041 1042 if Sbit >= SSU then 1043 Spos := Spos + 1; 1044 end if; 1045 1046 UI_Image (Spos); 1047 Spaces (Max_Spos_Length - UI_Image_Length); 1048 Write_Str (UI_Image_Buffer (1 .. UI_Image_Length)); 1049 1050 elsif Known_Component_Bit_Offset (Comp) 1051 and then List_Representation_Info = 3 1052 then 1053 Spaces (Max_Spos_Length - 2); 1054 Write_Str ("bit offset "); 1055 1056 if Starting_Position /= Uint_0 1057 or else Starting_First_Bit /= Uint_0 1058 then 1059 UI_Write (Starting_Position * SSU + Starting_First_Bit); 1060 Write_Str (" + "); 1061 end if; 1062 1063 Write_Val (Bofs, Paren => True); 1064 Write_Str (" size in bits = "); 1065 Write_Val (Esiz, Paren => True); 1066 Write_Eol; 1067 1068 goto Continue; 1069 1070 elsif Known_Normalized_Position (Comp) 1071 and then List_Representation_Info = 3 1072 then 1073 Spaces (Max_Spos_Length - 2); 1074 1075 if Starting_Position /= Uint_0 then 1076 Write_Char (' '); 1077 UI_Write (Starting_Position); 1078 Write_Str (" +"); 1079 end if; 1080 1081 Write_Val (Npos); 1082 1083 else 1084 -- For the packed case, we don't know the bit positions if 1085 -- we don't know the starting position. 1086 1087 if Is_Packed (Ent) then 1088 Write_Line ("?? range ? .. ??;"); 1089 goto Continue; 1090 1091 -- Otherwise we can continue 1092 1093 else 1094 Write_Str ("??"); 1095 end if; 1096 end if; 1097 1098 Write_Str (" range "); 1099 Sbit := Starting_First_Bit + Fbit; 1100 1101 if Sbit >= SSU then 1102 Sbit := Sbit - SSU; 1103 end if; 1104 1105 UI_Write (Sbit); 1106 Write_Str (" .. "); 1107 1108 -- Allowing Uint_0 here is an annoying special case. Really 1109 -- this should be a fine Esize value but currently it means 1110 -- unknown, except that we know after gigi has back annotated 1111 -- that a size of zero is real, since otherwise gigi back 1112 -- annotates using No_Uint as the value to indicate unknown). 1113 1114 if (Esize (Comp) = Uint_0 or else Known_Static_Esize (Comp)) 1115 and then Known_Static_Normalized_First_Bit (Comp) 1116 then 1117 Lbit := Sbit + Esiz - 1; 1118 1119 if Lbit < 10 then 1120 Write_Char (' '); 1121 end if; 1122 1123 UI_Write (Lbit); 1124 1125 -- The test for Esize (Comp) not Uint_0 here is an annoying 1126 -- special case. Officially a value of zero for Esize means 1127 -- unknown, but here we use the fact that we know that gigi 1128 -- annotates Esize with No_Uint, not Uint_0. Really everyone 1129 -- should use No_Uint??? 1130 1131 elsif List_Representation_Info < 3 1132 or else (Esize (Comp) /= Uint_0 and then Unknown_Esize (Comp)) 1133 then 1134 Write_Str ("??"); 1135 1136 -- List_Representation >= 3 and Known_Esize (Comp) 1137 1138 else 1139 Write_Val (Esiz, Paren => True); 1140 1141 -- If in front end layout mode, then dynamic size is stored 1142 -- in storage units, so renormalize for output 1143 1144 if not Back_End_Layout then 1145 Write_Str (" * "); 1146 Write_Int (SSU); 1147 end if; 1148 1149 -- Add appropriate first bit offset 1150 1151 if Sbit = 0 then 1152 Write_Str (" - 1"); 1153 1154 elsif Sbit = 1 then 1155 null; 1156 1157 else 1158 Write_Str (" + "); 1159 Write_Int (UI_To_Int (Sbit) - 1); 1160 end if; 1161 end if; 1162 1163 Write_Line (";"); 1164 end; 1165 1166 <<Continue>> 1167 Next_Component_Or_Discriminant (Comp); 1168 end loop; 1169 end List_Record_Layout; 1170 1171 -- Start of processing for List_Record_Info 1172 1173 begin 1174 Blank_Line; 1175 List_Type_Info (Ent); 1176 1177 Write_Str ("for "); 1178 List_Name (Ent); 1179 Write_Line (" use record"); 1180 1181 -- First find out max line length and max starting position 1182 -- length, for the purpose of lining things up nicely. 1183 1184 Compute_Max_Length (Ent); 1185 1186 -- Then do actual output based on those values 1187 1188 List_Record_Layout (Ent); 1189 1190 Write_Line ("end record;"); 1191 1192 List_Scalar_Storage_Order (Ent, Bytes_Big_Endian); 1193 end List_Record_Info; 1194 1195 ------------------- 1196 -- List_Rep_Info -- 1197 ------------------- 1198 1199 procedure List_Rep_Info (Bytes_Big_Endian : Boolean) is 1200 Col : Nat; 1201 1202 begin 1203 if List_Representation_Info /= 0 1204 or else List_Representation_Info_Mechanisms 1205 then 1206 for U in Main_Unit .. Last_Unit loop 1207 if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then 1208 Unit_Casing := Identifier_Casing (Source_Index (U)); 1209 1210 -- Normal case, list to standard output 1211 1212 if not List_Representation_Info_To_File then 1213 Write_Eol; 1214 Write_Str ("Representation information for unit "); 1215 Write_Unit_Name (Unit_Name (U)); 1216 Col := Column; 1217 Write_Eol; 1218 1219 for J in 1 .. Col - 1 loop 1220 Write_Char ('-'); 1221 end loop; 1222 1223 Write_Eol; 1224 List_Entities (Cunit_Entity (U), Bytes_Big_Endian); 1225 1226 -- List representation information to file 1227 1228 else 1229 Create_Repinfo_File_Access.all 1230 (Get_Name_String (File_Name (Source_Index (U)))); 1231 Set_Special_Output (Write_Info_Line'Access); 1232 List_Entities (Cunit_Entity (U), Bytes_Big_Endian); 1233 Set_Special_Output (null); 1234 Close_Repinfo_File_Access.all; 1235 end if; 1236 end if; 1237 end loop; 1238 end if; 1239 end List_Rep_Info; 1240 1241 ------------------------------- 1242 -- List_Scalar_Storage_Order -- 1243 ------------------------------- 1244 1245 procedure List_Scalar_Storage_Order 1246 (Ent : Entity_Id; 1247 Bytes_Big_Endian : Boolean) 1248 is 1249 procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean); 1250 -- Show attribute definition clause for Attr_Name (an endianness 1251 -- attribute), depending on whether or not the endianness is reversed 1252 -- compared to native endianness. 1253 1254 --------------- 1255 -- List_Attr -- 1256 --------------- 1257 1258 procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean) is 1259 begin 1260 Write_Str ("for "); 1261 List_Name (Ent); 1262 Write_Str ("'" & Attr_Name & " use System."); 1263 1264 if Bytes_Big_Endian xor Is_Reversed then 1265 Write_Str ("High"); 1266 else 1267 Write_Str ("Low"); 1268 end if; 1269 1270 Write_Line ("_Order_First;"); 1271 end List_Attr; 1272 1273 List_SSO : constant Boolean := 1274 Has_Rep_Item (Ent, Name_Scalar_Storage_Order) 1275 or else SSO_Set_Low_By_Default (Ent) 1276 or else SSO_Set_High_By_Default (Ent); 1277 -- Scalar_Storage_Order is displayed if specified explicitly 1278 -- or set by Default_Scalar_Storage_Order. 1279 1280 -- Start of processing for List_Scalar_Storage_Order 1281 1282 begin 1283 -- For record types, list Bit_Order if not default, or if SSO is shown 1284 1285 if Is_Record_Type (Ent) 1286 and then (List_SSO or else Reverse_Bit_Order (Ent)) 1287 then 1288 List_Attr ("Bit_Order", Reverse_Bit_Order (Ent)); 1289 end if; 1290 1291 -- List SSO if required. If not, then storage is supposed to be in 1292 -- native order. 1293 1294 if List_SSO then 1295 List_Attr ("Scalar_Storage_Order", Reverse_Storage_Order (Ent)); 1296 else 1297 pragma Assert (not Reverse_Storage_Order (Ent)); 1298 null; 1299 end if; 1300 end List_Scalar_Storage_Order; 1301 1302 -------------------- 1303 -- List_Type_Info -- 1304 -------------------- 1305 1306 procedure List_Type_Info (Ent : Entity_Id) is 1307 begin 1308 Blank_Line; 1309 1310 -- Do not list size info for unconstrained arrays, not meaningful 1311 1312 if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then 1313 null; 1314 1315 else 1316 -- If Esize and RM_Size are the same and known, list as Size. This 1317 -- is a common case, which we may as well list in simple form. 1318 1319 if Esize (Ent) = RM_Size (Ent) then 1320 Write_Str ("for "); 1321 List_Name (Ent); 1322 Write_Str ("'Size use "); 1323 Write_Val (Esize (Ent)); 1324 Write_Line (";"); 1325 1326 -- For now, temporary case, to be removed when gigi properly back 1327 -- annotates RM_Size, if RM_Size is not set, then list Esize as Size. 1328 -- This avoids odd Object_Size output till we fix things??? 1329 1330 elsif Unknown_RM_Size (Ent) then 1331 Write_Str ("for "); 1332 List_Name (Ent); 1333 Write_Str ("'Size use "); 1334 Write_Val (Esize (Ent)); 1335 Write_Line (";"); 1336 1337 -- Otherwise list size values separately if they are set 1338 1339 else 1340 Write_Str ("for "); 1341 List_Name (Ent); 1342 Write_Str ("'Object_Size use "); 1343 Write_Val (Esize (Ent)); 1344 Write_Line (";"); 1345 1346 -- Note on following check: The RM_Size of a discrete type can 1347 -- legitimately be set to zero, so a special check is needed. 1348 1349 Write_Str ("for "); 1350 List_Name (Ent); 1351 Write_Str ("'Value_Size use "); 1352 Write_Val (RM_Size (Ent)); 1353 Write_Line (";"); 1354 end if; 1355 end if; 1356 1357 Write_Str ("for "); 1358 List_Name (Ent); 1359 Write_Str ("'Alignment use "); 1360 Write_Val (Alignment (Ent)); 1361 Write_Line (";"); 1362 1363 -- Special stuff for fixed-point 1364 1365 if Is_Fixed_Point_Type (Ent) then 1366 1367 -- Write small (always a static constant) 1368 1369 Write_Str ("for "); 1370 List_Name (Ent); 1371 Write_Str ("'Small use "); 1372 UR_Write (Small_Value (Ent)); 1373 Write_Line (";"); 1374 1375 -- Write range if static 1376 1377 declare 1378 R : constant Node_Id := Scalar_Range (Ent); 1379 1380 begin 1381 if Nkind (Low_Bound (R)) = N_Real_Literal 1382 and then 1383 Nkind (High_Bound (R)) = N_Real_Literal 1384 then 1385 Write_Str ("for "); 1386 List_Name (Ent); 1387 Write_Str ("'Range use "); 1388 UR_Write (Realval (Low_Bound (R))); 1389 Write_Str (" .. "); 1390 UR_Write (Realval (High_Bound (R))); 1391 Write_Line (";"); 1392 end if; 1393 end; 1394 end if; 1395 end List_Type_Info; 1396 1397 ---------------------- 1398 -- Rep_Not_Constant -- 1399 ---------------------- 1400 1401 function Rep_Not_Constant (Val : Node_Ref_Or_Val) return Boolean is 1402 begin 1403 if Val = No_Uint or else Val < 0 then 1404 return True; 1405 else 1406 return False; 1407 end if; 1408 end Rep_Not_Constant; 1409 1410 --------------- 1411 -- Rep_Value -- 1412 --------------- 1413 1414 function Rep_Value 1415 (Val : Node_Ref_Or_Val; 1416 D : Discrim_List) return Uint 1417 is 1418 function B (Val : Boolean) return Uint; 1419 -- Returns Uint_0 for False, Uint_1 for True 1420 1421 function T (Val : Node_Ref_Or_Val) return Boolean; 1422 -- Returns True for 0, False for any non-zero (i.e. True) 1423 1424 function V (Val : Node_Ref_Or_Val) return Uint; 1425 -- Internal recursive routine to evaluate tree 1426 1427 function W (Val : Uint) return Word; 1428 -- Convert Val to Word, assuming Val is always in the Int range. This 1429 -- is a helper function for the evaluation of bitwise expressions like 1430 -- Bit_And_Expr, for which there is no direct support in uintp. Uint 1431 -- values out of the Int range are expected to be seen in such 1432 -- expressions only with overflowing byte sizes around, introducing 1433 -- inherent unreliabilities in computations anyway. 1434 1435 ------- 1436 -- B -- 1437 ------- 1438 1439 function B (Val : Boolean) return Uint is 1440 begin 1441 if Val then 1442 return Uint_1; 1443 else 1444 return Uint_0; 1445 end if; 1446 end B; 1447 1448 ------- 1449 -- T -- 1450 ------- 1451 1452 function T (Val : Node_Ref_Or_Val) return Boolean is 1453 begin 1454 if V (Val) = 0 then 1455 return False; 1456 else 1457 return True; 1458 end if; 1459 end T; 1460 1461 ------- 1462 -- V -- 1463 ------- 1464 1465 function V (Val : Node_Ref_Or_Val) return Uint is 1466 L, R, Q : Uint; 1467 1468 begin 1469 if Val >= 0 then 1470 return Val; 1471 1472 else 1473 declare 1474 Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val)); 1475 1476 begin 1477 case Node.Expr is 1478 when Cond_Expr => 1479 if T (Node.Op1) then 1480 return V (Node.Op2); 1481 else 1482 return V (Node.Op3); 1483 end if; 1484 1485 when Plus_Expr => 1486 return V (Node.Op1) + V (Node.Op2); 1487 1488 when Minus_Expr => 1489 return V (Node.Op1) - V (Node.Op2); 1490 1491 when Mult_Expr => 1492 return V (Node.Op1) * V (Node.Op2); 1493 1494 when Trunc_Div_Expr => 1495 return V (Node.Op1) / V (Node.Op2); 1496 1497 when Ceil_Div_Expr => 1498 return 1499 UR_Ceiling 1500 (V (Node.Op1) / UR_From_Uint (V (Node.Op2))); 1501 1502 when Floor_Div_Expr => 1503 return 1504 UR_Floor 1505 (V (Node.Op1) / UR_From_Uint (V (Node.Op2))); 1506 1507 when Trunc_Mod_Expr => 1508 return V (Node.Op1) rem V (Node.Op2); 1509 1510 when Floor_Mod_Expr => 1511 return V (Node.Op1) mod V (Node.Op2); 1512 1513 when Ceil_Mod_Expr => 1514 L := V (Node.Op1); 1515 R := V (Node.Op2); 1516 Q := UR_Ceiling (L / UR_From_Uint (R)); 1517 return L - R * Q; 1518 1519 when Exact_Div_Expr => 1520 return V (Node.Op1) / V (Node.Op2); 1521 1522 when Negate_Expr => 1523 return -V (Node.Op1); 1524 1525 when Min_Expr => 1526 return UI_Min (V (Node.Op1), V (Node.Op2)); 1527 1528 when Max_Expr => 1529 return UI_Max (V (Node.Op1), V (Node.Op2)); 1530 1531 when Abs_Expr => 1532 return UI_Abs (V (Node.Op1)); 1533 1534 when Truth_Andif_Expr => 1535 return B (T (Node.Op1) and then T (Node.Op2)); 1536 1537 when Truth_Orif_Expr => 1538 return B (T (Node.Op1) or else T (Node.Op2)); 1539 1540 when Truth_And_Expr => 1541 return B (T (Node.Op1) and then T (Node.Op2)); 1542 1543 when Truth_Or_Expr => 1544 return B (T (Node.Op1) or else T (Node.Op2)); 1545 1546 when Truth_Xor_Expr => 1547 return B (T (Node.Op1) xor T (Node.Op2)); 1548 1549 when Truth_Not_Expr => 1550 return B (not T (Node.Op1)); 1551 1552 when Bit_And_Expr => 1553 L := V (Node.Op1); 1554 R := V (Node.Op2); 1555 return UI_From_Int (Int (W (L) and W (R))); 1556 1557 when Lt_Expr => 1558 return B (V (Node.Op1) < V (Node.Op2)); 1559 1560 when Le_Expr => 1561 return B (V (Node.Op1) <= V (Node.Op2)); 1562 1563 when Gt_Expr => 1564 return B (V (Node.Op1) > V (Node.Op2)); 1565 1566 when Ge_Expr => 1567 return B (V (Node.Op1) >= V (Node.Op2)); 1568 1569 when Eq_Expr => 1570 return B (V (Node.Op1) = V (Node.Op2)); 1571 1572 when Ne_Expr => 1573 return B (V (Node.Op1) /= V (Node.Op2)); 1574 1575 when Discrim_Val => 1576 declare 1577 Sub : constant Int := UI_To_Int (Node.Op1); 1578 begin 1579 pragma Assert (Sub in D'Range); 1580 return D (Sub); 1581 end; 1582 1583 when Dynamic_Val => 1584 return No_Uint; 1585 end case; 1586 end; 1587 end if; 1588 end V; 1589 1590 ------- 1591 -- W -- 1592 ------- 1593 1594 -- We use an unchecked conversion to map Int values to their Word 1595 -- bitwise equivalent, which we could not achieve with a normal type 1596 -- conversion for negative Ints. We want bitwise equivalents because W 1597 -- is used as a helper for bit operators like Bit_And_Expr, and can be 1598 -- called for negative Ints in the context of aligning expressions like 1599 -- X+Align & -Align. 1600 1601 function W (Val : Uint) return Word is 1602 function To_Word is new Ada.Unchecked_Conversion (Int, Word); 1603 begin 1604 return To_Word (UI_To_Int (Val)); 1605 end W; 1606 1607 -- Start of processing for Rep_Value 1608 1609 begin 1610 if Val = No_Uint then 1611 return No_Uint; 1612 1613 else 1614 return V (Val); 1615 end if; 1616 end Rep_Value; 1617 1618 ------------ 1619 -- Spaces -- 1620 ------------ 1621 1622 procedure Spaces (N : Natural) is 1623 begin 1624 for J in 1 .. N loop 1625 Write_Char (' '); 1626 end loop; 1627 end Spaces; 1628 1629 --------------- 1630 -- Tree_Read -- 1631 --------------- 1632 1633 procedure Tree_Read is 1634 begin 1635 Rep_Table.Tree_Read; 1636 end Tree_Read; 1637 1638 ---------------- 1639 -- Tree_Write -- 1640 ---------------- 1641 1642 procedure Tree_Write is 1643 begin 1644 Rep_Table.Tree_Write; 1645 end Tree_Write; 1646 1647 --------------------- 1648 -- Write_Info_Line -- 1649 --------------------- 1650 1651 procedure Write_Info_Line (S : String) is 1652 begin 1653 Write_Repinfo_Line_Access.all (S (S'First .. S'Last - 1)); 1654 end Write_Info_Line; 1655 1656 --------------------- 1657 -- Write_Mechanism -- 1658 --------------------- 1659 1660 procedure Write_Mechanism (M : Mechanism_Type) is 1661 begin 1662 case M is 1663 when 0 => 1664 Write_Str ("default"); 1665 1666 when -1 => 1667 Write_Str ("copy"); 1668 1669 when -2 => 1670 Write_Str ("reference"); 1671 1672 when others => 1673 raise Program_Error; 1674 end case; 1675 end Write_Mechanism; 1676 1677 --------------- 1678 -- Write_Val -- 1679 --------------- 1680 1681 procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is 1682 begin 1683 if Rep_Not_Constant (Val) then 1684 if List_Representation_Info < 3 or else Val = No_Uint then 1685 Write_Str ("??"); 1686 1687 else 1688 if Paren then 1689 Write_Char ('('); 1690 end if; 1691 1692 if Back_End_Layout then 1693 List_GCC_Expression (Val); 1694 else 1695 Write_Name_Decoded (Chars (Get_Dynamic_SO_Entity (Val))); 1696 end if; 1697 1698 if Paren then 1699 Write_Char (')'); 1700 end if; 1701 end if; 1702 1703 else 1704 UI_Write (Val); 1705 end if; 1706 end Write_Val; 1707 1708end Repinfo; 1709