gcc/ada/repinfo.adb

   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-2025, 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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Alloc;
  27 with Atree;          use Atree;
  28 with Casing;         use Casing;
  29 with Debug;          use Debug;
  30 with Einfo;          use Einfo;
  31 with Einfo.Entities; use Einfo.Entities;
  32 with Einfo.Utils;    use Einfo.Utils;
  33 with GNAT.Heap_Sort_G;
  34 with Lib;            use Lib;
  35 with Namet;          use Namet;
  36 with Nlists;         use Nlists;
  37 with Opt;            use Opt;
  38 with Output;         use Output;
  39 with Osint.C;        use Osint.C;
  40 with Sem_Aux;        use Sem_Aux;
  41 with Sem_Eval;       use Sem_Eval;
  42 with Sem_Util;
  43 with Sinfo;          use Sinfo;
  44 with Sinfo.Nodes;    use Sinfo.Nodes;
  45 with Sinfo.Utils;    use Sinfo.Utils;
  46 with Sinput;         use Sinput;
  47 with Snames;         use Snames;
  48 with Stand;          use Stand;
  49 with Stringt;        use Stringt;
  50 with Table;
  51 with Ttypes;
  52 with Uname;          use Uname;
  53 with Urealp;         use Urealp;
  54
  55 with Ada.Unchecked_Conversion;
  56
  57 with GNAT.HTable;
  58
  59 package body Repinfo is
  60
  61    SSU : Pos renames Ttypes.System_Storage_Unit;
  62    --  Value for Storage_Unit
  63
  64    ---------------------------------------
  65    -- Representation of GCC Expressions --
  66    ---------------------------------------
  67
  68    --    A table internal to this unit is used to hold the values of back
  69    --    annotated expressions.
  70
  71    --    Node values are stored as Uint values using the negative of the node
  72    --    index in this table. Constants appear as non-negative Uint values.
  73
  74    type Exp_Node is record
  75       Expr : TCode;
  76       Op1  : Node_Ref_Or_Val;
  77       Op2  : Node_Ref_Or_Val;
  78       Op3  : Node_Ref_Or_Val;
  79    end record;
  80
  81    package Rep_Table is new Table.Table (
  82       Table_Component_Type => Exp_Node,
  83       Table_Index_Type     => Nat,
  84       Table_Low_Bound      => 1,
  85       Table_Initial        => Alloc.Rep_Table_Initial,
  86       Table_Increment      => Alloc.Rep_Table_Increment,
  87       Table_Name           => "BE_Rep_Table");
  88
  89    --------------------------------------------------------------
  90    -- Representation of Front-End Dynamic Size/Offset Entities --
  91    --------------------------------------------------------------
  92
  93    package Dynamic_SO_Entity_Table is new Table.Table (
  94       Table_Component_Type => Entity_Id,
  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           => "FE_Rep_Table");
 100
 101    Unit_Casing : Casing_Type;
 102    --  Identifier casing for current unit. This is set by List_Rep_Info for
 103    --  each unit, before calling subprograms which may read it.
 104
 105    Need_Separator : Boolean;
 106    --  Set True if a separator is needed before outputting any information for
 107    --  the current entity.
 108
 109    ------------------------------
 110    -- Set of Relevant Entities --
 111    ------------------------------
 112
 113    Relevant_Entities_Size : constant := 4093;
 114    --  Number of headers in hash table
 115
 116    subtype Entity_Header_Num is Integer range 0 .. Relevant_Entities_Size - 1;
 117    --  Range of headers in hash table
 118
 119    function Entity_Hash (Id : Entity_Id) return Entity_Header_Num;
 120    --  Simple hash function for Entity_Ids
 121
 122    package Relevant_Entities is new GNAT.Htable.Simple_HTable
 123      (Header_Num => Entity_Header_Num,
 124       Element    => Boolean,
 125       No_Element => False,
 126       Key        => Entity_Id,
 127       Hash       => Entity_Hash,
 128       Equal      => "=");
 129    --  Hash table to record which compiler-generated entities are relevant
 130
 131    -----------------------
 132    -- Local Subprograms --
 133    -----------------------
 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_Common_Type_Info (Ent : Entity_Id);
 153    --  List common type info (name, size, alignment) for type Ent
 154
 155    procedure List_Linker_Section (Ent : Entity_Id);
 156    --  List linker section for Ent (caller has checked that Ent is an entity
 157    --  for which the Linker_Section_Pragma field is defined).
 158
 159    procedure List_Location (Ent : Entity_Id);
 160    --  List location information for Ent
 161
 162    procedure List_Object_Info (Ent : Entity_Id);
 163    --  List representation info for object Ent
 164
 165    procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean);
 166    --  List representation info for record type Ent
 167
 168    procedure List_Scalar_Storage_Order
 169      (Ent              : Entity_Id;
 170       Bytes_Big_Endian : Boolean);
 171    --  List scalar storage order information for record or array type Ent.
 172    --  Also includes bit order information for record types, if necessary.
 173
 174    procedure List_Subprogram_Info (Ent : Entity_Id);
 175    --  List subprogram info for subprogram Ent
 176
 177    procedure List_Type_Info (Ent : Entity_Id);
 178    --  List type info for type Ent
 179
 180    function Compile_Time_Known_Rep (Val : Node_Ref_Or_Val) return Boolean;
 181    --  Returns True if Val represents a representation value that is known at
 182    --  compile time.
 183
 184    procedure Spaces (N : Natural);
 185    --  Output given number of spaces
 186
 187    procedure Write_Info_Line (S : String);
 188    --  Routine to write a line to Repinfo output file. This routine is passed
 189    --  as a special output procedure to Output.Set_Special_Output. Note that
 190    --  Write_Info_Line is called with an EOL character at the end of each line,
 191    --  as per the Output spec, but the internal call to the appropriate routine
 192    --  in Osint requires that the end of line sequence be stripped off.
 193
 194    procedure Write_Mechanism (M : Mechanism_Type);
 195    --  Writes symbolic string for mechanism represented by M
 196
 197    procedure Write_Separator;
 198    --  Called before outputting anything for an entity. Ensures that
 199    --  a separator precedes the output for a particular entity.
 200
 201    procedure Write_Unknown_Val;
 202    --  Writes symbolic string for an unknown or non-representable value
 203
 204    procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False);
 205    --  Given a representation value, write it out. No_Uint values or values
 206    --  dependent on discriminants are written as two question marks. If the
 207    --  flag Paren is set, then the output is surrounded in parentheses if it is
 208    --  other than a simple value.
 209
 210    ------------------------
 211    -- Create_Discrim_Ref --
 212    ------------------------
 213
 214    function Create_Discrim_Ref (Discr : Entity_Id) return Node_Ref is
 215    begin
 216       return Create_Node
 217         (Expr => Discrim_Val,
 218          Op1  => Discriminant_Number (Discr));
 219    end Create_Discrim_Ref;
 220
 221    ---------------------------
 222    -- Create_Dynamic_SO_Ref --
 223    ---------------------------
 224
 225    function Create_Dynamic_SO_Ref (E : Entity_Id) return Dynamic_SO_Ref is
 226    begin
 227       Dynamic_SO_Entity_Table.Append (E);
 228       return UI_From_Int (-Dynamic_SO_Entity_Table.Last);
 229    end Create_Dynamic_SO_Ref;
 230
 231    -----------------
 232    -- Create_Node --
 233    -----------------
 234
 235    function Create_Node
 236      (Expr : TCode;
 237       Op1  : Node_Ref_Or_Val;
 238       Op2  : Node_Ref_Or_Val := No_Uint;
 239       Op3  : Node_Ref_Or_Val := No_Uint) return Node_Ref
 240    is
 241    begin
 242       Rep_Table.Append (
 243         (Expr => Expr,
 244          Op1  => Op1,
 245          Op2  => Op2,
 246          Op3  => Op3));
 247       return UI_From_Int (-Rep_Table.Last);
 248    end Create_Node;
 249
 250    -----------------
 251    -- Entity_Hash --
 252    -----------------
 253
 254    function Entity_Hash (Id : Entity_Id) return Entity_Header_Num is
 255    begin
 256       return Entity_Header_Num (Id mod Relevant_Entities_Size);
 257    end Entity_Hash;
 258
 259    ---------------------------
 260    -- Get_Dynamic_SO_Entity --
 261    ---------------------------
 262
 263    function Get_Dynamic_SO_Entity (U : Dynamic_SO_Ref) return Entity_Id is
 264    begin
 265       return Dynamic_SO_Entity_Table.Table (-UI_To_Int (U));
 266    end Get_Dynamic_SO_Entity;
 267
 268    -----------------------
 269    -- Is_Dynamic_SO_Ref --
 270    -----------------------
 271
 272    function Is_Dynamic_SO_Ref (U : SO_Ref) return Boolean is
 273    begin
 274       return U < Uint_0;
 275    end Is_Dynamic_SO_Ref;
 276
 277    ----------------------
 278    -- Is_Static_SO_Ref --
 279    ----------------------
 280
 281    function Is_Static_SO_Ref (U : SO_Ref) return Boolean is
 282    begin
 283       return U >= Uint_0;
 284    end Is_Static_SO_Ref;
 285
 286    ---------
 287    -- lgx --
 288    ---------
 289
 290    procedure lgx (U : Node_Ref_Or_Val) is
 291    begin
 292       List_GCC_Expression (U);
 293       Write_Eol;
 294    end lgx;
 295
 296    ----------------------
 297    -- List_Array_Info --
 298    ----------------------
 299
 300    procedure List_Array_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
 301    begin
 302       Write_Separator;
 303
 304       if List_Representation_Info_To_JSON then
 305          Write_Line ("{");
 306       end if;
 307
 308       List_Common_Type_Info (Ent);
 309
 310       if List_Representation_Info_To_JSON then
 311          Write_Line (",");
 312          Write_Str ("  ""Component_Size"": ");
 313          Write_Val (Component_Size (Ent));
 314       else
 315          Write_Str ("for ");
 316          List_Name (Ent);
 317          Write_Str ("'Component_Size use ");
 318          Write_Val (Component_Size (Ent));
 319          Write_Line (";");
 320       end if;
 321
 322       List_Scalar_Storage_Order (Ent, Bytes_Big_Endian);
 323
 324       List_Linker_Section (Ent);
 325
 326       if List_Representation_Info_To_JSON then
 327          Write_Eol;
 328          Write_Line ("}");
 329       end if;
 330
 331       --  The component type is relevant for an array
 332
 333       if List_Representation_Info = 4
 334         and then Is_Itype (Component_Type (Base_Type (Ent)))
 335       then
 336          Relevant_Entities.Set (Component_Type (Base_Type (Ent)), True);
 337       end if;
 338    end List_Array_Info;
 339
 340    ---------------------------
 341    -- List_Common_Type_Info --
 342    ---------------------------
 343
 344    procedure List_Common_Type_Info (Ent : Entity_Id) is
 345    begin
 346       if List_Representation_Info_To_JSON then
 347          Write_Str ("  ""name"": """);
 348          List_Name (Ent);
 349          Write_Line (""",");
 350          List_Location (Ent);
 351       end if;
 352
 353       --  Do not list size info for unconstrained arrays, not meaningful
 354
 355       if Is_Array_Type (Ent) and then not Is_Constrained (Ent) then
 356          null;
 357
 358       else
 359          if Known_Esize (Ent) and then Known_RM_Size (Ent) then
 360             --  If Esize and RM_Size are the same, list as Size. This is a
 361             --  common case, which we may as well list in simple form.
 362
 363             if Esize (Ent) = RM_Size (Ent) then
 364                if List_Representation_Info_To_JSON then
 365                   Write_Str ("  ""Size"": ");
 366                   Write_Val (Esize (Ent));
 367                   Write_Line (",");
 368                else
 369                   Write_Str ("for ");
 370                   List_Name (Ent);
 371                   Write_Str ("'Size use ");
 372                   Write_Val (Esize (Ent));
 373                   Write_Line (";");
 374                end if;
 375
 376             --  Otherwise list size values separately
 377
 378             else
 379                if List_Representation_Info_To_JSON then
 380                   Write_Str ("  ""Object_Size"": ");
 381                   Write_Val (Esize (Ent));
 382                   Write_Line (",");
 383
 384                   Write_Str ("  ""Value_Size"": ");
 385                   Write_Val (RM_Size (Ent));
 386                   Write_Line (",");
 387
 388                else
 389                   Write_Str ("for ");
 390                   List_Name (Ent);
 391                   Write_Str ("'Object_Size use ");
 392                   Write_Val (Esize (Ent));
 393                   Write_Line (";");
 394
 395                   Write_Str ("for ");
 396                   List_Name (Ent);
 397                   Write_Str ("'Value_Size use ");
 398                   Write_Val (RM_Size (Ent));
 399                   Write_Line (";");
 400                end if;
 401             end if;
 402          end if;
 403       end if;
 404
 405       if Known_Alignment (Ent) then
 406          if List_Representation_Info_To_JSON then
 407             Write_Str ("  ""Alignment"": ");
 408             Write_Val (Alignment (Ent));
 409          else
 410             Write_Str ("for ");
 411             List_Name (Ent);
 412             Write_Str ("'Alignment use ");
 413             Write_Val (Alignment (Ent));
 414             Write_Line (";");
 415          end if;
 416
 417       --  Alignment is not always set for concurrent types, class-wide types,
 418       --  cloned subtypes, or when doing semantic analysis only. Representation
 419       --  aspects are not computed for types declared in a generic unit.
 420
 421       else
 422          --  Add unknown alignment entry in JSON format to ensure the format is
 423          --  valid, as a comma is added by the caller before another field.
 424
 425          if List_Representation_Info_To_JSON then
 426             Write_Str ("  ""Alignment"": ");
 427             Write_Unknown_Val;
 428          end if;
 429
 430          pragma Assert (not Expander_Active
 431            or else Is_Concurrent_Type (Ent)
 432            or else Is_Class_Wide_Type (Ent)
 433            or else (Ekind (Ent) = E_Record_Subtype
 434                      and then Present (Cloned_Subtype (Ent))
 435                      and then Has_Delayed_Freeze (Cloned_Subtype (Ent)))
 436            or else Sem_Util.In_Generic_Scope (Ent));
 437       end if;
 438    end List_Common_Type_Info;
 439
 440    -------------------
 441    -- List_Entities --
 442    -------------------
 443
 444    procedure List_Entities
 445      (Ent              : Entity_Id;
 446       Bytes_Big_Endian : Boolean;
 447       In_Subprogram    : Boolean := False)
 448    is
 449       E : Entity_Id;
 450
 451    begin
 452       --  List entity if we have one, and it is not a renaming declaration.
 453       --  For renamings, we don't get proper information, and really it makes
 454       --  sense to restrict the output to the renamed entity.
 455
 456       if Present (Ent)
 457         and then Nkind (Declaration_Node (Ent)) not in N_Renaming_Declaration
 458         and then not Is_Ignored_Ghost_Entity (Ent)
 459       then
 460          --  If entity is a subprogram and we are listing mechanisms,
 461          --  then we need to list mechanisms for this entity. We skip this
 462          --  if it is a nested subprogram, as the information has already
 463          --  been produced when listing the enclosing scope.
 464
 465          if List_Representation_Info_Mechanisms
 466            and then Is_Subprogram_Or_Entry (Ent)
 467            and then not In_Subprogram
 468          then
 469             List_Subprogram_Info (Ent);
 470          end if;
 471
 472          E := First_Entity (Ent);
 473          while Present (E) loop
 474             --  We list entities that come from source (excluding private or
 475             --  incomplete types or deferred constants, for which we will list
 476             --  the information for the full view). If requested, we also list
 477             --  relevant entities that have been generated when processing the
 478             --  original entities coming from source. But if debug flag A is
 479             --  set, then all entities are listed.
 480
 481             if ((Comes_From_Source (E)
 482                    or else (Ekind (E) = E_Block
 483                               and then
 484                             Nkind (Parent (E)) = N_Implicit_Label_Declaration
 485                               and then
 486                             Comes_From_Source (Label_Construct (Parent (E)))))
 487               and then not Is_Incomplete_Or_Private_Type (E)
 488               and then not (Ekind (E) = E_Constant
 489                               and then Present (Full_View (E))))
 490               or else (List_Representation_Info = 4
 491                          and then Relevant_Entities.Get (E))
 492               or else Debug_Flag_AA
 493             then
 494                if Is_Subprogram (E) then
 495                   if List_Representation_Info_Mechanisms then
 496                      List_Subprogram_Info (E);
 497                   end if;
 498
 499                   --  Recurse into entities local to subprogram
 500
 501                   List_Entities (E, Bytes_Big_Endian, True);
 502
 503                elsif Ekind (E) in E_Entry
 504                                 | E_Entry_Family
 505                                 | E_Subprogram_Type
 506                then
 507                   if List_Representation_Info_Mechanisms then
 508                      List_Subprogram_Info (E);
 509                   end if;
 510
 511                elsif Is_Record_Type (E) then
 512                   if List_Representation_Info >= 1 then
 513                      if Is_Private_Type (E) then
 514                         List_Record_Info (Full_View (E), Bytes_Big_Endian);
 515                      else
 516                         List_Record_Info (E, Bytes_Big_Endian);
 517                      end if;
 518
 519                      --  Recurse into entities local to a record type
 520
 521                      if List_Representation_Info = 4 then
 522                         List_Entities (E, Bytes_Big_Endian, False);
 523                      end if;
 524                   end if;
 525
 526                elsif Is_Array_Type (E) then
 527                   if List_Representation_Info >= 1 then
 528                      List_Array_Info (E, Bytes_Big_Endian);
 529                   end if;
 530
 531                elsif Is_Type (E) then
 532                   if List_Representation_Info >= 2 then
 533                      List_Type_Info (E);
 534                   end if;
 535
 536                --  Formals and renamings are not annotated, so we skip them
 537                --  here.
 538
 539                elsif Ekind (E) in E_Constant
 540                                 | E_Loop_Parameter
 541                                 | E_Variable
 542                  and then Nkind (Parent (E)) /= N_Object_Renaming_Declaration
 543                then
 544                   if List_Representation_Info >= 2 then
 545                      List_Object_Info (E);
 546                   end if;
 547                end if;
 548
 549                --  Recurse into nested package, but not child packages, and not
 550                --  nested package renamings (in particular renamings of the
 551                --  enclosing package, as for some Java bindings and for generic
 552                --  instances).
 553
 554                if Ekind (E) = E_Package then
 555                   if No (Renamed_Entity (E)) and then not Is_Child_Unit (E)
 556                   then
 557                      List_Entities (E, Bytes_Big_Endian);
 558                   end if;
 559
 560                --  Recurse into bodies
 561
 562                elsif Ekind (E) in E_Package_Body
 563                                 | E_Protected_Body
 564                                 | E_Protected_Type
 565                                 | E_Subprogram_Body
 566                                 | E_Task_Body
 567                                 | E_Task_Type
 568                then
 569                   List_Entities (E, Bytes_Big_Endian);
 570
 571                --  Recurse into blocks
 572
 573                elsif Ekind (E) = E_Block then
 574                   List_Entities (E, Bytes_Big_Endian);
 575                end if;
 576             end if;
 577
 578             Next_Entity (E);
 579          end loop;
 580       end if;
 581    end List_Entities;
 582
 583    -------------------------
 584    -- List_GCC_Expression --
 585    -------------------------
 586
 587    procedure List_GCC_Expression (U : Node_Ref_Or_Val) is
 588
 589       procedure Print_Expr (Val : Node_Ref_Or_Val);
 590       --  Internal recursive procedure to print expression
 591
 592       ----------------
 593       -- Print_Expr --
 594       ----------------
 595
 596       procedure Print_Expr (Val : Node_Ref_Or_Val) is
 597       begin
 598          if Val >= 0 then
 599             UI_Write (Val, Decimal);
 600
 601          else
 602             declare
 603                Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
 604
 605                procedure Unop (S : String);
 606                --  Output text for unary operator with S being operator name
 607
 608                procedure Binop (S : String);
 609                --  Output text for binary operator with S being operator name
 610
 611                ----------
 612                -- Unop --
 613                ----------
 614
 615                procedure Unop (S : String) is
 616                begin
 617                   if List_Representation_Info_To_JSON then
 618                      Write_Str ("{ ""code"": """);
 619                      if S (S'Last) = ' ' then
 620                         Write_Str (S (S'First .. S'Last - 1));
 621                      else
 622                         Write_Str (S);
 623                      end if;
 624                      Write_Str (""", ""operands"": [ ");
 625                      Print_Expr (Node.Op1);
 626                      Write_Str (" ] }");
 627                   else
 628                      Write_Str (S);
 629                      Print_Expr (Node.Op1);
 630                   end if;
 631                end Unop;
 632
 633                -----------
 634                -- Binop --
 635                -----------
 636
 637                procedure Binop (S : String) is
 638                begin
 639                   if List_Representation_Info_To_JSON then
 640                      Write_Str ("{ ""code"": """);
 641                      Write_Str (S (S'First + 1 .. S'Last - 1));
 642                      Write_Str (""", ""operands"": [ ");
 643                      Print_Expr (Node.Op1);
 644                      Write_Str (", ");
 645                      Print_Expr (Node.Op2);
 646                      Write_Str (" ] }");
 647                   else
 648                      Write_Char ('(');
 649                      Print_Expr (Node.Op1);
 650                      Write_Str (S);
 651                      Print_Expr (Node.Op2);
 652                      Write_Char (')');
 653                   end if;
 654                end Binop;
 655
 656             --  Start of processing for Print_Expr
 657
 658             begin
 659                case Node.Expr is
 660                   when Cond_Expr =>
 661                      if List_Representation_Info_To_JSON then
 662                         Write_Str ("{ ""code"": ""?<>""");
 663                         Write_Str (", ""operands"": [ ");
 664                         Print_Expr (Node.Op1);
 665                         Write_Str (", ");
 666                         Print_Expr (Node.Op2);
 667                         Write_Str (", ");
 668                         Print_Expr (Node.Op3);
 669                         Write_Str (" ] }");
 670                      else
 671                         Write_Str ("(if ");
 672                         Print_Expr (Node.Op1);
 673                         Write_Str (" then ");
 674                         Print_Expr (Node.Op2);
 675                         Write_Str (" else ");
 676                         Print_Expr (Node.Op3);
 677                         Write_Str (")");
 678                      end if;
 679
 680                   when Plus_Expr =>
 681                      Binop (" + ");
 682
 683                   when Minus_Expr =>
 684                      Binop (" - ");
 685
 686                   when Mult_Expr =>
 687                      Binop (" * ");
 688
 689                   when Trunc_Div_Expr =>
 690                      Binop (" /t ");
 691
 692                   when Ceil_Div_Expr =>
 693                      Binop (" /c ");
 694
 695                   when Floor_Div_Expr =>
 696                      Binop (" /f ");
 697
 698                   when Trunc_Mod_Expr =>
 699                      Binop (" modt ");
 700
 701                   when Ceil_Mod_Expr =>
 702                      Binop (" modc ");
 703
 704                   when Floor_Mod_Expr =>
 705                      Binop (" modf ");
 706
 707                   when Exact_Div_Expr =>
 708                      Binop (" /e ");
 709
 710                   when Negate_Expr =>
 711                      Unop ("-");
 712
 713                   when Min_Expr =>
 714                      Binop (" min ");
 715
 716                   when Max_Expr =>
 717                      Binop (" max ");
 718
 719                   when Abs_Expr =>
 720                      Unop ("abs ");
 721
 722                   when Truth_And_Expr =>
 723                      Binop (" and ");
 724
 725                   when Truth_Or_Expr =>
 726                      Binop (" or ");
 727
 728                   when Truth_Xor_Expr =>
 729                      Binop (" xor ");
 730
 731                   when Truth_Not_Expr =>
 732                      Unop ("not ");
 733
 734                   when Lt_Expr =>
 735                      Binop (" < ");
 736
 737                   when Le_Expr =>
 738                      Binop (" <= ");
 739
 740                   when Gt_Expr =>
 741                      Binop (" > ");
 742
 743                   when Ge_Expr =>
 744                      Binop (" >= ");
 745
 746                   when Eq_Expr =>
 747                      Binop (" == ");
 748
 749                   when Ne_Expr =>
 750                      Binop (" != ");
 751
 752                   when Bit_And_Expr =>
 753                      Binop (" & ");
 754
 755                   when Discrim_Val =>
 756                      Unop ("#");
 757
 758                   when Dynamic_Val =>
 759                      Unop ("var");
 760                end case;
 761             end;
 762          end if;
 763       end Print_Expr;
 764
 765    --  Start of processing for List_GCC_Expression
 766
 767    begin
 768       if No (U) then
 769          Write_Unknown_Val;
 770       else
 771          Print_Expr (U);
 772       end if;
 773    end List_GCC_Expression;
 774
 775    -------------------------
 776    -- List_Linker_Section --
 777    -------------------------
 778
 779    procedure List_Linker_Section (Ent : Entity_Id) is
 780       Args : List_Id;
 781       Sect : Node_Id;
 782
 783    begin
 784       if Present (Linker_Section_Pragma (Ent)) then
 785          Args := Pragma_Argument_Associations (Linker_Section_Pragma (Ent));
 786          Sect := Expr_Value_S (Get_Pragma_Arg (Last (Args)));
 787
 788          if List_Representation_Info_To_JSON then
 789             Write_Line (",");
 790             Write_Str ("  ""Linker_Section"": """);
 791          else
 792             Write_Str ("pragma Linker_Section (");
 793             List_Name (Ent);
 794             Write_Str (", """);
 795          end if;
 796
 797          pragma Assert (Nkind (Sect) = N_String_Literal);
 798          String_To_Name_Buffer (Strval (Sect));
 799          Write_Str (Name_Buffer (1 .. Name_Len));
 800          Write_Str ("""");
 801          if not List_Representation_Info_To_JSON then
 802             Write_Line (");");
 803          end if;
 804       end if;
 805    end List_Linker_Section;
 806
 807    -------------------
 808    -- List_Location --
 809    -------------------
 810
 811    procedure List_Location (Ent : Entity_Id) is
 812    begin
 813       pragma Assert (List_Representation_Info_To_JSON);
 814       Write_Str ("  ""location"": """);
 815       Write_Location (Sloc (Ent));
 816       Write_Line (""",");
 817    end List_Location;
 818
 819    ---------------
 820    -- List_Name --
 821    ---------------
 822
 823    procedure List_Name (Ent : Entity_Id) is
 824       C : Character;
 825
 826    begin
 827       --  In JSON mode, we recurse up to Standard. This is also valid in
 828       --  default mode where we recurse up to the first compilation unit and
 829       --  should not get to Standard.
 830
 831       if Scope (Ent) = Standard_Standard then
 832          null;
 833       elsif not Is_Compilation_Unit (Scope (Ent))
 834         or else List_Representation_Info_To_JSON
 835       then
 836          List_Name (Scope (Ent));
 837          Write_Char ('.');
 838       end if;
 839
 840       Get_Unqualified_Decoded_Name_String (Chars (Ent));
 841       Set_Casing (Unit_Casing);
 842
 843       --  The name of operators needs to be properly escaped for JSON
 844
 845       for J in 1 .. Name_Len loop
 846          C := Name_Buffer (J);
 847          if C = '"' and then List_Representation_Info_To_JSON then
 848             Write_Char ('\');
 849          end if;
 850          Write_Char (C);
 851       end loop;
 852    end List_Name;
 853
 854    ---------------------
 855    -- List_Object_Info --
 856    ---------------------
 857
 858    procedure List_Object_Info (Ent : Entity_Id) is
 859    begin
 860       --  If size and alignment have not been computed (e.g. if we are in a
 861       --  generic unit, or if the back end is not being run), don't try to
 862       --  print them.
 863
 864       if not Known_Esize (Ent) or else not Known_Alignment (Ent) then
 865          return;
 866       end if;
 867
 868       Write_Separator;
 869
 870       if List_Representation_Info_To_JSON then
 871          Write_Line ("{");
 872
 873          Write_Str ("  ""name"": """);
 874          List_Name (Ent);
 875          Write_Line (""",");
 876          List_Location (Ent);
 877
 878          Write_Str ("  ""Size"": ");
 879          Write_Val (Esize (Ent));
 880          Write_Line (",");
 881
 882          Write_Str ("  ""Alignment"": ");
 883          Write_Val (Alignment (Ent));
 884
 885          List_Linker_Section (Ent);
 886
 887          Write_Eol;
 888          Write_Line ("}");
 889
 890       else
 891          Write_Str ("for ");
 892          List_Name (Ent);
 893          Write_Str ("'Size use ");
 894          Write_Val (Esize (Ent));
 895          Write_Line (";");
 896
 897          Write_Str ("for ");
 898          List_Name (Ent);
 899          Write_Str ("'Alignment use ");
 900          Write_Val (Alignment (Ent));
 901          Write_Line (";");
 902
 903          List_Linker_Section (Ent);
 904       end if;
 905
 906       --  The type is relevant for an object
 907
 908       if List_Representation_Info = 4 and then Is_Itype (Etype (Ent)) then
 909          Relevant_Entities.Set (Etype (Ent), True);
 910       end if;
 911    end List_Object_Info;
 912
 913    ----------------------
 914    -- List_Record_Info --
 915    ----------------------
 916
 917    procedure List_Record_Info (Ent : Entity_Id; Bytes_Big_Endian : Boolean) is
 918       procedure Compute_Max_Length
 919         (Ent                : Entity_Id;
 920          Starting_Position  : Uint := Uint_0;
 921          Starting_First_Bit : Uint := Uint_0;
 922          Prefix_Length      : Natural := 0);
 923       --  Internal recursive procedure to compute the max length
 924
 925       procedure List_Component_Layout
 926         (Ent                : Entity_Id;
 927          Starting_Position  : Uint := Uint_0;
 928          Starting_First_Bit : Uint := Uint_0;
 929          Prefix             : String := "";
 930          Indent             : Natural := 0);
 931       --  Procedure to display the layout of a single component
 932
 933       procedure List_Record_Layout
 934         (Ent                : Entity_Id;
 935          Starting_Position  : Uint := Uint_0;
 936          Starting_First_Bit : Uint := Uint_0;
 937          Prefix             : String := "");
 938       --  Internal recursive procedure to display the layout
 939
 940       procedure List_Structural_Record_Layout
 941         (Ent       : Entity_Id;
 942          Ext_Ent   : Entity_Id;
 943          Ext_Level : Integer := 0;
 944          Variant   : Node_Id := Empty;
 945          Indent    : Natural := 0);
 946       --  Internal recursive procedure to display the structural layout.
 947       --  If Ext_Ent is not equal to Ent, it is an extension of Ent and
 948       --  Ext_Level is the number of successive extensions between them,
 949       --  with the convention that this number is positive when we are
 950       --  called from the fixed part of Ext_Ent and negative when we are
 951       --  called from the variant part of Ext_Ent, if any; this is needed
 952       --  because the fixed and variant parts of a parent of an extension
 953       --  cannot be listed contiguously from this extension's viewpoint.
 954       --  If Variant is present, it's for a variant in the variant part
 955       --  instead of the common part of Ent. Indent is the indentation.
 956
 957       Incomplete_Layout : exception;
 958       --  Exception raised if the layout is incomplete in -gnatc mode
 959
 960       Not_In_Extended_Main : exception;
 961       --  Exception raised when an ancestor is not declared in the main unit
 962
 963       Max_Name_Length : Natural := 0;
 964       Max_Spos_Length : Natural := 0;
 965
 966       ------------------------
 967       -- Compute_Max_Length --
 968       ------------------------
 969
 970       procedure Compute_Max_Length
 971         (Ent                : Entity_Id;
 972          Starting_Position  : Uint := Uint_0;
 973          Starting_First_Bit : Uint := Uint_0;
 974          Prefix_Length      : Natural := 0)
 975       is
 976          Comp : Entity_Id;
 977
 978       begin
 979          Comp := First_Component_Or_Discriminant (Ent);
 980          while Present (Comp) loop
 981
 982             --  Skip a completely hidden discriminant or a discriminant in an
 983             --  unchecked union (since it is not there).
 984
 985             if Ekind (Comp) = E_Discriminant
 986               and then (Is_Completely_Hidden (Comp)
 987                          or else Is_Unchecked_Union (Ent))
 988             then
 989                goto Continue;
 990             end if;
 991
 992             --  Skip _Parent component in extension (to avoid overlap)
 993
 994             if Chars (Comp) = Name_uParent then
 995                goto Continue;
 996             end if;
 997
 998             --  All other cases
 999
1000             declare
1001                Ctyp : constant Entity_Id := Underlying_Type (Etype (Comp));
1002                Bofs : constant Uint      := Component_Bit_Offset (Comp);
1003                Npos : Uint;
1004                Fbit : Uint;
1005                Spos : Uint;
1006                Sbit : Uint;
1007
1008                Name_Length : Natural;
1009
1010             begin
1011                Get_Decoded_Name_String (Chars (Comp));
1012                Name_Length := Prefix_Length + Name_Len;
1013
1014                if Compile_Time_Known_Rep (Bofs) then
1015                   Npos := Bofs / SSU;
1016                   Fbit := Bofs mod SSU;
1017
1018                   --  Complete annotation in case not done
1019
1020                   if not Known_Normalized_First_Bit (Comp) then
1021                      Set_Normalized_Position  (Comp, Npos);
1022                      Set_Normalized_First_Bit (Comp, Fbit);
1023                   end if;
1024
1025                   Spos := Starting_Position  + Npos;
1026                   Sbit := Starting_First_Bit + Fbit;
1027
1028                   if Sbit >= SSU then
1029                      Spos := Spos + 1;
1030                      Sbit := Sbit - SSU;
1031                   end if;
1032
1033                   --  If extended information is requested, recurse fully into
1034                   --  record components, i.e. skip the outer level.
1035
1036                   if List_Representation_Info_Extended
1037                     and then Is_Record_Type (Ctyp)
1038                   then
1039                      Compute_Max_Length (Ctyp, Spos, Sbit, Name_Length + 1);
1040                      goto Continue;
1041                   end if;
1042
1043                   UI_Image (Spos, Format => Decimal);
1044                else
1045                   --  If the record is not packed, then we know that all fields
1046                   --  whose position is not specified have starting normalized
1047                   --  bit position of zero.
1048
1049                   if not Known_Normalized_First_Bit (Comp)
1050                     and then not Is_Packed (Ent)
1051                   then
1052                      Set_Normalized_First_Bit (Comp, Uint_0);
1053                   end if;
1054
1055                   UI_Image_Length := 2; -- For "??" marker
1056                end if;
1057
1058                Max_Name_Length := Natural'Max (Max_Name_Length, Name_Length);
1059                Max_Spos_Length :=
1060                  Natural'Max (Max_Spos_Length, UI_Image_Length);
1061             end;
1062
1063          <<Continue>>
1064             Next_Component_Or_Discriminant (Comp);
1065          end loop;
1066       end Compute_Max_Length;
1067
1068       ---------------------------
1069       -- List_Component_Layout --
1070       ---------------------------
1071
1072       procedure List_Component_Layout
1073         (Ent                : Entity_Id;
1074          Starting_Position  : Uint := Uint_0;
1075          Starting_First_Bit : Uint := Uint_0;
1076          Prefix             : String := "";
1077          Indent             : Natural := 0)
1078       is
1079          Esiz  : constant Uint := Esize (Ent);
1080          Npos  : constant Uint := Normalized_Position (Ent);
1081          Fbit  : constant Uint := Normalized_First_Bit (Ent);
1082          Spos  : Uint;
1083          Sbit  : Uint := No_Uint;
1084          Lbit  : Uint;
1085
1086       begin
1087          if List_Representation_Info_To_JSON then
1088             Spaces (Indent);
1089             Write_Line ("    {");
1090             Spaces (Indent);
1091             Write_Str ("      ""name"": """);
1092             Write_Str (Prefix);
1093             Write_Str (Name_Buffer (1 .. Name_Len));
1094             Write_Line (""",");
1095             if Ekind (Ent) = E_Discriminant then
1096                Spaces (Indent);
1097                Write_Str ("      ""discriminant"": ");
1098                UI_Write (Discriminant_Number (Ent), Decimal);
1099                Write_Line (",");
1100             end if;
1101             Spaces (Indent);
1102             Write_Str ("      ""Position"": ");
1103          else
1104             Write_Str ("   ");
1105             Write_Str (Prefix);
1106             Write_Str (Name_Buffer (1 .. Name_Len));
1107             Spaces (Max_Name_Length - Prefix'Length - Name_Len);
1108             Write_Str (" at ");
1109          end if;
1110
1111          if Known_Static_Normalized_Position (Ent) then
1112             Spos := Starting_Position  + Npos;
1113             Sbit := Starting_First_Bit + Fbit;
1114
1115             if Sbit >= SSU then
1116                Spos := Spos + 1;
1117             end if;
1118
1119             UI_Image (Spos, Format => Decimal);
1120             Spaces (Max_Spos_Length - UI_Image_Length);
1121             Write_Str (UI_Image_Buffer (1 .. UI_Image_Length));
1122
1123          elsif Known_Normalized_Position (Ent)
1124            and then List_Representation_Info >= 3
1125          then
1126             Spaces (Max_Spos_Length - 2);
1127
1128             if Starting_Position /= Uint_0 then
1129                UI_Write (Starting_Position, Decimal);
1130                Write_Str (" + ");
1131             end if;
1132
1133             Write_Val (Npos);
1134
1135          else
1136             Write_Unknown_Val;
1137          end if;
1138
1139          if List_Representation_Info_To_JSON then
1140             Write_Line (",");
1141             Spaces (Indent);
1142             Write_Str ("      ""First_Bit"": ");
1143          else
1144             Write_Str (" range  ");
1145          end if;
1146
1147          if Known_Static_Normalized_First_Bit (Ent) then
1148             Sbit := Starting_First_Bit + Fbit;
1149
1150             if Sbit >= SSU then
1151                Sbit := Sbit - SSU;
1152             end if;
1153
1154             UI_Write (Sbit, Decimal);
1155          else
1156             Write_Unknown_Val;
1157          end if;
1158
1159          if List_Representation_Info_To_JSON then
1160             Write_Line (", ");
1161             Spaces (Indent);
1162             Write_Str ("      ""Size"": ");
1163          else
1164             Write_Str (" .. ");
1165          end if;
1166
1167          if Known_Static_Esize (Ent)
1168            and then Known_Static_Normalized_First_Bit (Ent)
1169          then
1170             Lbit := Sbit + Esiz - 1;
1171
1172             if List_Representation_Info_To_JSON then
1173                UI_Write (Esiz, Decimal);
1174             else
1175                if Lbit >= 0 and then Lbit < 10 then
1176                   Write_Char (' ');
1177                end if;
1178
1179                UI_Write (Lbit, Decimal);
1180             end if;
1181
1182          elsif List_Representation_Info < 3 or else not Known_Esize (Ent) then
1183             Write_Unknown_Val;
1184
1185          --  List_Representation >= 3 and Known_Esize (Ent)
1186
1187          else
1188             Write_Val (Esiz, Paren => not List_Representation_Info_To_JSON);
1189
1190             --  Add appropriate first bit offset
1191
1192             if not List_Representation_Info_To_JSON then
1193                if Sbit = 0 then
1194                   Write_Str (" - 1");
1195
1196                elsif Sbit = 1 then
1197                   null;
1198
1199                else
1200                   Write_Str (" + ");
1201                   Write_Int (UI_To_Int (Sbit) - 1);
1202                end if;
1203             end if;
1204          end if;
1205
1206          if List_Representation_Info_To_JSON then
1207             Write_Eol;
1208             Spaces (Indent);
1209             Write_Str ("    }");
1210          else
1211             Write_Line (";");
1212          end if;
1213
1214          --  The type is relevant for a component
1215
1216          if List_Representation_Info = 4 and then Is_Itype (Etype (Ent)) then
1217             Relevant_Entities.Set (Etype (Ent), True);
1218          end if;
1219       end List_Component_Layout;
1220
1221       ------------------------
1222       -- List_Record_Layout --
1223       ------------------------
1224
1225       procedure List_Record_Layout
1226         (Ent                : Entity_Id;
1227          Starting_Position  : Uint := Uint_0;
1228          Starting_First_Bit : Uint := Uint_0;
1229          Prefix             : String := "")
1230       is
1231          function First_Comp_Or_Discr (Ent : Entity_Id) return Entity_Id;
1232          --  Like First_Component_Or_Discriminant, but reorder the components
1233          --  according to their bit offset if need be.
1234
1235          -------------------------
1236          -- First_Comp_Or_Discr --
1237          -------------------------
1238
1239          function First_Comp_Or_Discr (Ent : Entity_Id) return Entity_Id is
1240
1241             function Is_Placed_Before (C1, C2 : Entity_Id) return Boolean;
1242             --  Return True if components C1 and C2 are in the same component
1243             --  list and component C1 is placed before component C2 in there.
1244
1245             ----------------------
1246             -- Is_Placed_Before --
1247             ----------------------
1248
1249             function Is_Placed_Before (C1, C2 : Entity_Id) return Boolean is
1250                L1 : constant Node_Id := Parent (Parent (C1));
1251                L2 : constant Node_Id := Parent (Parent (C2));
1252
1253             begin
1254                --  Discriminants and top-level components are considered to be
1255                --  in the same list, although this is not syntactically true.
1256
1257                return (L1 = L2
1258                         or else (Nkind (Parent (L1)) /= N_Variant
1259                                   and then Nkind (Parent (L2)) /= N_Variant))
1260                  and then Known_Static_Component_Bit_Offset (C1)
1261                  and then Known_Static_Component_Bit_Offset (C2)
1262                  and then
1263                    Component_Bit_Offset (C1) < Component_Bit_Offset (C2);
1264             end Is_Placed_Before;
1265
1266             --  Local variables
1267
1268             Comp    : Entity_Id;
1269             N_Comp  : Natural := 0;
1270             Prev    : Entity_Id;
1271             Reorder : Boolean := False;
1272
1273          --  Start of processing for First_Comp_Or_Discr
1274
1275          begin
1276             --  Reordering is needed only for -gnatRh
1277
1278             if not List_Representation_Info_Holes then
1279                return First_Component_Or_Discriminant (Ent);
1280             end if;
1281
1282             --  Count the number of components and whether reordering is needed
1283
1284             Comp := First_Component_Or_Discriminant (Ent);
1285             Prev := Comp;
1286
1287             while Present (Comp) loop
1288                N_Comp := N_Comp + 1;
1289
1290                if not Reorder then
1291                   Reorder := Is_Placed_Before (Comp, Prev);
1292                end if;
1293
1294                Prev := Comp;
1295                Next_Component_Or_Discriminant (Comp);
1296             end loop;
1297
1298             --  Reorder the components, if need be, by directly reshuffling the
1299             --  list of entities between First_Entity and Last_Entity, which is
1300             --  safe because we are invoked after compilation is finished.
1301
1302             if Reorder then
1303                declare
1304                   Comps : array (Natural range 0 .. N_Comp) of Entity_Id;
1305                   --  Support array for the heapsort
1306
1307                   function Lt (Op1, Op2 : Natural) return Boolean is
1308                     (Is_Placed_Before (Comps (Op1), Comps (Op2)));
1309                   --  Compare function for the heapsort
1310
1311                   procedure Move (From : Natural; To : Natural);
1312                   pragma Inline (Move);
1313                   --  Move procedure for the heapsort
1314
1315                   ----------
1316                   -- Move --
1317                   ----------
1318
1319                   procedure Move (From : Natural; To : Natural) is
1320                   begin
1321                      Comps (To) := Comps (From);
1322                   end Move;
1323
1324                   package HS is new GNAT.Heap_Sort_G (Lt => Lt, Move => Move);
1325                   --  The heapsort for record components
1326
1327                begin
1328                   --  Pack the components into the array
1329
1330                   N_Comp := 0;
1331                   Comp := First_Component_Or_Discriminant (Ent);
1332
1333                   while Present (Comp) loop
1334                      N_Comp := N_Comp + 1;
1335                      Comps (N_Comp) := Comp;
1336
1337                      Next_Component_Or_Discriminant (Comp);
1338                   end loop;
1339
1340                   --  Sort the array
1341
1342                   HS.Sort (N_Comp);
1343
1344                   --  Unpack the component into the list of entities
1345
1346                   Set_First_Entity (Ent, Comps (1));
1347                   Set_Prev_Entity (Comps (1), Empty);
1348                   for J in 1 .. N_Comp - 1 loop
1349                      Set_Next_Entity (Comps (J), Comps (J + 1));
1350                      Set_Prev_Entity (Comps (J + 1), Comps (J));
1351                   end loop;
1352                   Set_Next_Entity (Comps (N_Comp), Empty);
1353                   Set_Last_Entity (Ent, Comps (N_Comp));
1354                end;
1355             end if;
1356
1357             return First_Component_Or_Discriminant (Ent);
1358          end First_Comp_Or_Discr;
1359
1360          --  Local variables
1361
1362          Bit_Offset : Uint := Uint_0;
1363          Comp       : Entity_Id;
1364          First      : Boolean := True;
1365
1366       --  Start of processing for List_Record_Layout
1367
1368       begin
1369          Comp := First_Comp_Or_Discr (Ent);
1370          while Present (Comp) loop
1371
1372             --  Skip a completely hidden discriminant or a discriminant in an
1373             --  unchecked union (since it is not there).
1374
1375             if Ekind (Comp) = E_Discriminant
1376               and then (Is_Completely_Hidden (Comp)
1377                          or else Is_Unchecked_Union (Ent))
1378             then
1379                null;
1380
1381             --  Skip _Parent component in extension (to avoid overlap)
1382
1383             elsif Chars (Comp) = Name_uParent then
1384                null;
1385
1386             --  All other cases
1387
1388             else
1389                declare
1390                   C : constant Entity_Id :=
1391                         (if Known_Normalized_Position (Comp)
1392                          then Comp
1393                          else Original_Record_Component (Comp));
1394                   --  The Parent_Subtype in an extension is not back-annotated
1395                   --  but its layout is the same as that of the parent type.
1396
1397                   Ctyp : constant Entity_Id := Underlying_Type (Etype (C));
1398
1399                begin
1400                   Get_Decoded_Name_String (Chars (C));
1401                   Set_Casing (Unit_Casing);
1402
1403                   --  If extended information is requested, recurse fully into
1404                   --  record components, i.e. skip the outer level.
1405
1406                   if List_Representation_Info_Extended
1407                     and then Is_Record_Type (Ctyp)
1408                     and then Known_Static_Normalized_Position (C)
1409                     and then Known_Static_Normalized_First_Bit (C)
1410                   then
1411                      declare
1412                         Npos : constant Uint := Normalized_Position (C);
1413                         Fbit : constant Uint := Normalized_First_Bit (C);
1414                         Pref : constant String :=
1415                                  Prefix & Name_Buffer (1 .. Name_Len) & ".";
1416
1417                         Spos : Uint;
1418                         Sbit : Uint;
1419
1420                      begin
1421                         Spos := Starting_Position  + Npos;
1422                         Sbit := Starting_First_Bit + Fbit;
1423
1424                         if Sbit >= SSU then
1425                            Spos := Spos + 1;
1426                            Sbit := Sbit - SSU;
1427                         end if;
1428
1429                         List_Record_Layout (Ctyp, Spos, Sbit, Pref);
1430                      end;
1431
1432                   else
1433                      if List_Representation_Info_To_JSON then
1434                         if First then
1435                            Write_Eol;
1436                            First := False;
1437                         else
1438                            Write_Line (",");
1439                         end if;
1440                      end if;
1441
1442                      --  If information about holes is requested, update the
1443                      --  current bit offset and report any (static) gap.
1444
1445                      if List_Representation_Info_Holes
1446                        and then Known_Static_Component_Bit_Offset (C)
1447                      then
1448                         declare
1449                            Gap : constant Uint :=
1450                                    Component_Bit_Offset (C) - Bit_Offset;
1451                         begin
1452                            if Gap > Uint_0 then
1453                               Write_Str ("   -- ");
1454                               UI_Write (Gap, Decimal);
1455                               Write_Line (" bits unused --");
1456                            end if;
1457
1458                            if Known_Static_Esize (C) then
1459                               Bit_Offset :=
1460                                 Component_Bit_Offset (C) + Esize (C);
1461                            end if;
1462                         end;
1463                      end if;
1464
1465                      List_Component_Layout
1466                        (C, Starting_Position, Starting_First_Bit, Prefix);
1467                   end if;
1468                end;
1469             end if;
1470
1471             Next_Component_Or_Discriminant (Comp);
1472          end loop;
1473       end List_Record_Layout;
1474
1475       -----------------------------------
1476       -- List_Structural_Record_Layout --
1477       -----------------------------------
1478
1479       procedure List_Structural_Record_Layout
1480         (Ent       : Entity_Id;
1481          Ext_Ent   : Entity_Id;
1482          Ext_Level : Integer := 0;
1483          Variant   : Node_Id := Empty;
1484          Indent    : Natural := 0)
1485       is
1486          function Derived_Discriminant (Disc : Entity_Id) return Entity_Id;
1487          --  This function assumes that Ext_Ent is an extension of Ent.
1488          --  Disc is a discriminant of Ent that does not itself constrain a
1489          --  discriminant of the parent type of Ent. Return the discriminant
1490          --  of Ext_Ent that ultimately constrains Disc, if any.
1491
1492          ----------------------------
1493          --  Derived_Discriminant  --
1494          ----------------------------
1495
1496          function Derived_Discriminant (Disc : Entity_Id) return Entity_Id is
1497             Corr_Disc    : Entity_Id;
1498             Derived_Disc : Entity_Id;
1499
1500          begin
1501             --  Deal with an extension of a type with unknown discriminants
1502
1503             if Has_Unknown_Discriminants (Ext_Ent)
1504               and then Present (Underlying_Record_View (Ext_Ent))
1505             then
1506                Derived_Disc :=
1507                  First_Discriminant (Underlying_Record_View (Ext_Ent));
1508             else
1509                Derived_Disc := First_Discriminant (Ext_Ent);
1510             end if;
1511
1512             --  Loop over the discriminants of the extension
1513
1514             while Present (Derived_Disc) loop
1515
1516                --  Check if this discriminant constrains another discriminant.
1517                --  If so, find the ultimately constrained discriminant and
1518                --  compare with the original components in the base type.
1519
1520                if Present (Corresponding_Discriminant (Derived_Disc)) then
1521                   Corr_Disc := Corresponding_Discriminant (Derived_Disc);
1522
1523                   while Present (Corresponding_Discriminant (Corr_Disc)) loop
1524                      Corr_Disc := Corresponding_Discriminant (Corr_Disc);
1525                   end loop;
1526
1527                   if Original_Record_Component (Corr_Disc) =
1528                      Original_Record_Component (Disc)
1529                   then
1530                      return Derived_Disc;
1531                   end if;
1532                end if;
1533
1534                Next_Discriminant (Derived_Disc);
1535             end loop;
1536
1537             --  Disc is not constrained by a discriminant of Ext_Ent
1538
1539             return Empty;
1540          end Derived_Discriminant;
1541
1542          --  Local declarations
1543
1544          Comp       : Node_Id;
1545          Comp_List  : Node_Id;
1546          First      : Boolean := True;
1547          Parent_Ent : Entity_Id := Empty;
1548          Var        : Node_Id;
1549
1550       --  Start of processing for List_Structural_Record_Layout
1551
1552       begin
1553          --  If we are dealing with a variant, just process the components
1554
1555          if Present (Variant) then
1556             Comp_List := Component_List (Variant);
1557
1558          --  Otherwise, we are dealing with the full record and need to get
1559          --  to its definition in order to retrieve its structural layout.
1560
1561          else
1562             declare
1563                Definition : Node_Id :=
1564                               Type_Definition (Declaration_Node (Ent));
1565
1566                Is_Extension : constant Boolean :=
1567                                 Is_Tagged_Type (Ent)
1568                                   and then Nkind (Definition) =
1569                                              N_Derived_Type_Definition;
1570
1571                Disc        : Entity_Id;
1572                Listed_Disc : Entity_Id;
1573                Parent_Type : Entity_Id;
1574
1575             begin
1576                --  If this is an extension, first list the layout of the parent
1577                --  and then proceed to the extension part, if any.
1578
1579                if Is_Extension then
1580                   Parent_Type := Parent_Subtype (Ent);
1581                   if No (Parent_Type) then
1582                      raise Incomplete_Layout;
1583                   end if;
1584
1585                   if Is_Private_Type (Parent_Type) then
1586                      Parent_Type := Full_View (Parent_Type);
1587                      pragma Assert (Present (Parent_Type));
1588                   end if;
1589
1590                   --  Do not list variants if one of them has been selected
1591
1592                   if Has_Static_Discriminants (Parent_Type) then
1593                      List_Record_Layout (Parent_Type);
1594
1595                   else
1596                      Parent_Type := Base_Type (Parent_Type);
1597
1598                      if Is_Private_Type (Parent_Type) then
1599                         Parent_Type := Full_View (Parent_Type);
1600                         pragma Assert (Present (Parent_Type));
1601                      end if;
1602
1603                      if not In_Extended_Main_Source_Unit (Parent_Type) then
1604                         raise Not_In_Extended_Main;
1605                      end if;
1606
1607                      Parent_Ent := Parent_Type;
1608                      if Ext_Level >= 0 then
1609                         List_Structural_Record_Layout
1610                           (Parent_Ent, Ext_Ent, Ext_Level + 1);
1611                      end if;
1612                   end if;
1613
1614                   First := False;
1615
1616                   if Present (Record_Extension_Part (Definition)) then
1617                      Definition := Record_Extension_Part (Definition);
1618                   end if;
1619                end if;
1620
1621                --  If the record has discriminants and is not an unchecked
1622                --  union, then display them now. Note that, even if this is
1623                --  a structural layout, we list the visible discriminants.
1624
1625                if Has_Discriminants (Ent)
1626                  and then not Is_Unchecked_Union (Ent)
1627                  and then Ext_Level >= 0
1628                then
1629                   Disc := First_Discriminant (Ent);
1630                   while Present (Disc) loop
1631
1632                      --  If this is a record extension and the discriminant is
1633                      --  the renaming of another discriminant, skip it.
1634
1635                      if Is_Extension
1636                        and then Present (Corresponding_Discriminant (Disc))
1637                      then
1638                         goto Continue_Disc;
1639                      end if;
1640
1641                      --  If this is the parent type of an extension, retrieve
1642                      --  the derived discriminant from the extension, if any.
1643
1644                      if Ent /= Ext_Ent then
1645                         Listed_Disc := Derived_Discriminant (Disc);
1646
1647                         if No (Listed_Disc) then
1648                            goto Continue_Disc;
1649
1650                         elsif not Known_Normalized_Position (Listed_Disc) then
1651                            Listed_Disc :=
1652                              Original_Record_Component (Listed_Disc);
1653                         end if;
1654
1655                      else
1656                         Listed_Disc := Disc;
1657                      end if;
1658
1659                      Get_Decoded_Name_String (Chars (Listed_Disc));
1660                      Set_Casing (Unit_Casing);
1661
1662                      if First then
1663                         Write_Eol;
1664                         First := False;
1665                      else
1666                         Write_Line (",");
1667                      end if;
1668
1669                      List_Component_Layout (Listed_Disc, Indent => Indent);
1670
1671                   <<Continue_Disc>>
1672                      Next_Discriminant (Disc);
1673                   end loop;
1674                end if;
1675
1676                Comp_List := Component_List (Definition);
1677             end;
1678          end if;
1679
1680          --  Bail out for the null record
1681
1682          if No (Comp_List) then
1683             return;
1684          end if;
1685
1686          --  Now deal with the regular components, if any
1687
1688          if Present (Component_Items (Comp_List))
1689            and then (Present (Variant) or else Ext_Level >= 0)
1690          then
1691             Comp := First_Non_Pragma (Component_Items (Comp_List));
1692             while Present (Comp) loop
1693
1694                --  Skip _Parent component in extension (to avoid overlap)
1695
1696                if Chars (Defining_Identifier (Comp)) = Name_uParent then
1697                   goto Continue_Comp;
1698                end if;
1699
1700                Get_Decoded_Name_String (Chars (Defining_Identifier (Comp)));
1701                Set_Casing (Unit_Casing);
1702
1703                if First then
1704                   Write_Eol;
1705                   First := False;
1706                else
1707                   Write_Line (",");
1708                end if;
1709
1710                List_Component_Layout
1711                  (Defining_Identifier (Comp), Indent => Indent);
1712
1713             <<Continue_Comp>>
1714                Next_Non_Pragma (Comp);
1715             end loop;
1716          end if;
1717
1718          --  Stop there if we are called from the fixed part of Ext_Ent,
1719          --  we'll do the variant part when called from its variant part.
1720
1721          if Ext_Level > 0 then
1722             return;
1723          end if;
1724
1725          --  List the layout of the variant part of the parent, if any
1726
1727          if Present (Parent_Ent) then
1728             List_Structural_Record_Layout
1729               (Parent_Ent, Ext_Ent, Ext_Level - 1);
1730          end if;
1731
1732          --  We are done if there is no variant part
1733
1734          if No (Variant_Part (Comp_List)) then
1735             return;
1736          end if;
1737
1738          Write_Eol;
1739          Spaces (Indent);
1740          Write_Line ("  ],");
1741          Spaces (Indent);
1742          Write_Str ("  """);
1743          for J in Ext_Level .. -1 loop
1744             Write_Str ("parent_");
1745          end loop;
1746          Write_Str ("variant"" : [");
1747
1748          --  Otherwise we recurse on each variant
1749
1750          Var := First_Non_Pragma (Variants (Variant_Part (Comp_List)));
1751          First := True;
1752          while Present (Var) loop
1753             if First then
1754                Write_Eol;
1755                First := False;
1756             else
1757                Write_Line (",");
1758             end if;
1759
1760             Spaces (Indent);
1761             Write_Line ("    {");
1762             Spaces (Indent);
1763             Write_Str ("      ""present"": ");
1764             Write_Val (Present_Expr (Var));
1765             Write_Line (",");
1766             Spaces (Indent);
1767             Write_Str ("      ""record"": [");
1768
1769             List_Structural_Record_Layout
1770               (Ent, Ext_Ent, Ext_Level, Var, Indent + 4);
1771
1772             Write_Eol;
1773             Spaces (Indent);
1774             Write_Line ("      ]");
1775             Spaces (Indent);
1776             Write_Str ("    }");
1777             Next_Non_Pragma (Var);
1778          end loop;
1779       end List_Structural_Record_Layout;
1780
1781       --  Use the original record type giving the layout of components
1782       --  to avoid repeated reordering when -gnatRh is specified.
1783
1784       Rec : constant Entity_Id :=
1785         (if Ekind (Ent) = E_Record_Subtype
1786            and then Present (Cloned_Subtype (Ent))
1787          then (if Is_Private_Type (Cloned_Subtype (Ent))
1788                then Full_View (Cloned_Subtype (Ent))
1789                else Cloned_Subtype (Ent))
1790          else Ent);
1791
1792    --  Start of processing for List_Record_Info
1793
1794    begin
1795       Write_Separator;
1796
1797       if List_Representation_Info_To_JSON then
1798          Write_Line ("{");
1799       end if;
1800
1801       List_Common_Type_Info (Ent);
1802
1803       --  First find out max line length and max starting position
1804       --  length, for the purpose of lining things up nicely.
1805
1806       Compute_Max_Length (Rec);
1807
1808       --  Then do actual output based on those values
1809
1810       if List_Representation_Info_To_JSON then
1811          Write_Line (",");
1812          Write_Str ("  ""record"": [");
1813
1814          --  ??? We can output structural layout only for base types fully
1815          --  declared in the extended main source unit for the time being,
1816          --  because otherwise declarations might not be processed at all.
1817
1818          if Is_Base_Type (Rec) then
1819             begin
1820                List_Structural_Record_Layout (Rec, Rec);
1821
1822             exception
1823                when Incomplete_Layout
1824                   | Not_In_Extended_Main
1825                =>
1826                   List_Record_Layout (Rec);
1827
1828                when others =>
1829                   raise Program_Error;
1830             end;
1831          else
1832             List_Record_Layout (Rec);
1833          end if;
1834
1835          Write_Eol;
1836          Write_Str ("  ]");
1837       else
1838          Write_Str ("for ");
1839          List_Name (Ent);
1840          Write_Line (" use record");
1841
1842          List_Record_Layout (Rec);
1843
1844          Write_Line ("end record;");
1845       end if;
1846
1847       List_Scalar_Storage_Order (Ent, Bytes_Big_Endian);
1848
1849       List_Linker_Section (Ent);
1850
1851       if List_Representation_Info_To_JSON then
1852          Write_Eol;
1853          Write_Line ("}");
1854       end if;
1855
1856       --  The type is relevant for a record subtype
1857
1858       if List_Representation_Info = 4
1859         and then not Is_Base_Type (Ent)
1860         and then Is_Itype (Etype (Ent))
1861       then
1862          Relevant_Entities.Set (Etype (Ent), True);
1863       end if;
1864    end List_Record_Info;
1865
1866    -------------------
1867    -- List_Rep_Info --
1868    -------------------
1869
1870    procedure List_Rep_Info (Bytes_Big_Endian : Boolean) is
1871       Col : Nat;
1872
1873    begin
1874       if List_Representation_Info /= 0
1875         or else List_Representation_Info_Mechanisms
1876       then
1877          --  For the normal case, we output a single JSON stream
1878
1879          if not List_Representation_Info_To_File
1880            and then List_Representation_Info_To_JSON
1881          then
1882             Write_Line ("[");
1883             Need_Separator := False;
1884          end if;
1885
1886          for U in Main_Unit .. Last_Unit loop
1887             if In_Extended_Main_Source_Unit (Cunit_Entity (U)) then
1888                Unit_Casing := Identifier_Casing (Source_Index (U));
1889
1890                if List_Representation_Info = 4 then
1891                   Relevant_Entities.Reset;
1892                end if;
1893
1894                --  Normal case, list to standard output
1895
1896                if not List_Representation_Info_To_File then
1897                   if not List_Representation_Info_To_JSON then
1898                      Write_Eol;
1899                      Write_Str ("Representation information for unit ");
1900                      Write_Unit_Name (Unit_Name (U));
1901                      Col := Column;
1902                      Write_Eol;
1903
1904                      for J in 1 .. Col - 1 loop
1905                         Write_Char ('-');
1906                      end loop;
1907
1908                      Write_Eol;
1909                      Need_Separator := True;
1910                   end if;
1911
1912                   List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
1913
1914                --  List representation information to file
1915
1916                else
1917                   Create_Repinfo_File
1918                     (Get_Name_String (File_Name (Source_Index (U))));
1919                   Set_Special_Output (Write_Info_Line'Access);
1920                   if List_Representation_Info_To_JSON then
1921                      Write_Line ("[");
1922                   end if;
1923                   Need_Separator := False;
1924                   List_Entities (Cunit_Entity (U), Bytes_Big_Endian);
1925                   if List_Representation_Info_To_JSON then
1926                      Write_Line ("]");
1927                   end if;
1928                   Cancel_Special_Output;
1929                   Close_Repinfo_File;
1930                end if;
1931             end if;
1932          end loop;
1933
1934          if not List_Representation_Info_To_File
1935            and then List_Representation_Info_To_JSON
1936          then
1937             Write_Line ("]");
1938          end if;
1939       end if;
1940    end List_Rep_Info;
1941
1942    -------------------------------
1943    -- List_Scalar_Storage_Order --
1944    -------------------------------
1945
1946    procedure List_Scalar_Storage_Order
1947      (Ent              : Entity_Id;
1948       Bytes_Big_Endian : Boolean)
1949    is
1950       procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean);
1951       --  Show attribute definition clause for Attr_Name (an endianness
1952       --  attribute), depending on whether or not the endianness is reversed
1953       --  compared to native endianness.
1954
1955       ---------------
1956       -- List_Attr --
1957       ---------------
1958
1959       procedure List_Attr (Attr_Name : String; Is_Reversed : Boolean) is
1960       begin
1961          if List_Representation_Info_To_JSON then
1962             Write_Line (",");
1963             Write_Str ("  """);
1964             Write_Str (Attr_Name);
1965             Write_Str (""": ""System.");
1966          else
1967             Write_Str ("for ");
1968             List_Name (Ent);
1969             Write_Char (''');
1970             Write_Str (Attr_Name);
1971             Write_Str (" use System.");
1972          end if;
1973
1974          if Bytes_Big_Endian xor Is_Reversed then
1975             Write_Str ("High");
1976          else
1977             Write_Str ("Low");
1978          end if;
1979
1980          Write_Str ("_Order_First");
1981          if List_Representation_Info_To_JSON then
1982             Write_Str ("""");
1983          else
1984             Write_Line (";");
1985          end if;
1986       end List_Attr;
1987
1988       List_SSO : constant Boolean :=
1989                    Has_Rep_Item (Ent, Name_Scalar_Storage_Order)
1990                      or else SSO_Set_Low_By_Default  (Ent)
1991                      or else SSO_Set_High_By_Default (Ent);
1992       --  Scalar_Storage_Order is displayed if specified explicitly or set by
1993       --  Default_Scalar_Storage_Order.
1994
1995    --  Start of processing for List_Scalar_Storage_Order
1996
1997    begin
1998       --  For record types, list Bit_Order if not default, or if SSO is shown
1999
2000       --  Also, when -gnatR4 is in effect always list bit order and scalar
2001       --  storage order explicitly, so that you don't need to know the native
2002       --  endianness of the target for which the output was produced in order
2003       --  to interpret it.
2004
2005       if Is_Record_Type (Ent)
2006         and then (List_SSO
2007                    or else Reverse_Bit_Order (Ent)
2008                    or else List_Representation_Info = 4)
2009       then
2010          List_Attr ("Bit_Order", Reverse_Bit_Order (Ent));
2011       end if;
2012
2013       --  List SSO if required. If not, then storage is supposed to be in
2014       --  native order.
2015
2016       if List_SSO or else List_Representation_Info = 4 then
2017          List_Attr ("Scalar_Storage_Order", Reverse_Storage_Order (Ent));
2018       else
2019          pragma Assert (not Reverse_Storage_Order (Ent));
2020          null;
2021       end if;
2022    end List_Scalar_Storage_Order;
2023
2024    --------------------------
2025    -- List_Subprogram_Info --
2026    --------------------------
2027
2028    procedure List_Subprogram_Info (Ent : Entity_Id) is
2029       First : Boolean := True;
2030       Plen  : Natural;
2031       Form  : Entity_Id;
2032
2033    begin
2034       Write_Separator;
2035
2036       if List_Representation_Info_To_JSON then
2037          Write_Line ("{");
2038          Write_Str ("  ""name"": """);
2039          List_Name (Ent);
2040          Write_Line (""",");
2041          List_Location (Ent);
2042
2043          Write_Str ("  ""Convention"": """);
2044       else
2045          case Ekind (Ent) is
2046             when E_Function =>
2047                Write_Str ("function ");
2048
2049             when E_Operator =>
2050                Write_Str ("operator ");
2051
2052             when E_Procedure =>
2053                Write_Str ("procedure ");
2054
2055             when E_Subprogram_Type =>
2056                Write_Str ("type ");
2057
2058             when E_Entry
2059                | E_Entry_Family
2060             =>
2061                Write_Str ("entry ");
2062
2063             when others =>
2064                raise Program_Error;
2065          end case;
2066
2067          List_Name (Ent);
2068          Write_Str (" declared at ");
2069          Write_Location (Sloc (Ent));
2070          Write_Eol;
2071
2072          Write_Str ("convention : ");
2073       end if;
2074
2075       case Convention (Ent) is
2076          when Convention_Ada =>
2077             Write_Str ("Ada");
2078
2079          when Convention_Ada_Pass_By_Copy =>
2080             Write_Str ("Ada_Pass_By_Copy");
2081
2082          when Convention_Ada_Pass_By_Reference =>
2083             Write_Str ("Ada_Pass_By_Reference");
2084
2085          when Convention_Intrinsic =>
2086             Write_Str ("Intrinsic");
2087
2088          when Convention_Entry =>
2089             Write_Str ("Entry");
2090
2091          when Convention_Protected =>
2092             Write_Str ("Protected");
2093
2094          when Convention_Assembler =>
2095             Write_Str ("Assembler");
2096
2097          when Convention_C =>
2098             Write_Str ("C");
2099
2100          when Convention_C_Variadic =>
2101             declare
2102                N : Nat :=
2103                  Convention_Id'Pos (Convention (Ent)) -
2104                    Convention_Id'Pos (Convention_C_Variadic_0);
2105             begin
2106                Write_Str ("C_Variadic_");
2107                if N >= 10 then
2108                   Write_Char ('1');
2109                   N := N - 10;
2110                end if;
2111                pragma Assert (N < 10);
2112                Write_Char (Character'Val (Character'Pos ('0') + N));
2113             end;
2114
2115          when Convention_COBOL =>
2116             Write_Str ("COBOL");
2117
2118          when Convention_CPP =>
2119             Write_Str ("C++");
2120
2121          when Convention_Fortran =>
2122             Write_Str ("Fortran");
2123
2124          when Convention_Stdcall =>
2125             Write_Str ("Stdcall");
2126
2127          when Convention_Stubbed =>
2128             Write_Str ("Stubbed");
2129       end case;
2130
2131       if List_Representation_Info_To_JSON then
2132          Write_Line (""",");
2133          Write_Str ("  ""formal"": [");
2134       else
2135          Write_Eol;
2136       end if;
2137
2138       --  Find max length of formal name
2139
2140       Plen := 0;
2141       Form := First_Formal (Ent);
2142       while Present (Form) loop
2143          Get_Unqualified_Decoded_Name_String (Chars (Form));
2144
2145          if Name_Len > Plen then
2146             Plen := Name_Len;
2147          end if;
2148
2149          Next_Formal (Form);
2150       end loop;
2151
2152       --  Output formals and mechanisms
2153
2154       Form := First_Formal (Ent);
2155       while Present (Form) loop
2156          Get_Unqualified_Decoded_Name_String (Chars (Form));
2157          Set_Casing (Unit_Casing);
2158
2159          if List_Representation_Info_To_JSON then
2160             if First then
2161                Write_Eol;
2162                First := False;
2163             else
2164                Write_Line (",");
2165             end if;
2166
2167             Write_Line ("    {");
2168             Write_Str ("      ""name"": """);
2169             Write_Str (Name_Buffer (1 .. Name_Len));
2170             Write_Line (""",");
2171
2172             Write_Str ("      ""mechanism"": """);
2173             Write_Mechanism (Mechanism (Form));
2174             Write_Line ("""");
2175             Write_Str ("    }");
2176          else
2177             while Name_Len <= Plen loop
2178                Name_Len := Name_Len + 1;
2179                Name_Buffer (Name_Len) := ' ';
2180             end loop;
2181
2182             Write_Str ("   ");
2183             Write_Str (Name_Buffer (1 .. Plen + 1));
2184             Write_Str (": passed by ");
2185
2186             Write_Mechanism (Mechanism (Form));
2187             Write_Eol;
2188          end if;
2189
2190          Next_Formal (Form);
2191       end loop;
2192
2193       if List_Representation_Info_To_JSON then
2194          Write_Eol;
2195          Write_Str ("  ]");
2196       end if;
2197
2198       if Ekind (Ent) = E_Function then
2199          if List_Representation_Info_To_JSON then
2200             Write_Line (",");
2201             Write_Str ("  ""mechanism"": """);
2202             Write_Mechanism (Mechanism (Ent));
2203             Write_Str ("""");
2204          else
2205             Write_Str ("returns by ");
2206             Write_Mechanism (Mechanism (Ent));
2207             Write_Eol;
2208          end if;
2209       end if;
2210
2211       if not Is_Entry (Ent) then
2212          List_Linker_Section (Ent);
2213       end if;
2214
2215       if List_Representation_Info_To_JSON then
2216          Write_Eol;
2217          Write_Line ("}");
2218       end if;
2219    end List_Subprogram_Info;
2220
2221    --------------------
2222    -- List_Type_Info --
2223    --------------------
2224
2225    procedure List_Type_Info (Ent : Entity_Id) is
2226    begin
2227       Write_Separator;
2228
2229       if List_Representation_Info_To_JSON then
2230          Write_Line ("{");
2231       end if;
2232
2233       List_Common_Type_Info (Ent);
2234
2235       --  Special stuff for fixed-point
2236
2237       if Is_Fixed_Point_Type (Ent) then
2238
2239          --  Write small (always a static constant)
2240
2241          if List_Representation_Info_To_JSON then
2242             Write_Line (",");
2243             Write_Str ("  ""Small"": ");
2244             UR_Write_To_JSON (Small_Value (Ent));
2245          else
2246             Write_Str ("for ");
2247             List_Name (Ent);
2248             Write_Str ("'Small use ");
2249             UR_Write (Small_Value (Ent));
2250             Write_Line (";");
2251          end if;
2252
2253          --  Write range if static
2254
2255          declare
2256             R : constant Node_Id := Scalar_Range (Ent);
2257
2258          begin
2259             if Nkind (Low_Bound (R)) = N_Real_Literal
2260                  and then
2261                Nkind (High_Bound (R)) = N_Real_Literal
2262             then
2263                if List_Representation_Info_To_JSON then
2264                   Write_Line (",");
2265                   Write_Str ("  ""Range"": [ ");
2266                   UR_Write_To_JSON (Realval (Low_Bound (R)));
2267                   Write_Str (", ");
2268                   UR_Write_To_JSON (Realval (High_Bound (R)));
2269                   Write_Str (" ]");
2270                else
2271                   Write_Str ("for ");
2272                   List_Name (Ent);
2273                   Write_Str ("'Range use ");
2274                   UR_Write (Realval (Low_Bound (R)));
2275                   Write_Str (" .. ");
2276                   UR_Write (Realval (High_Bound (R)));
2277                   Write_Line (";");
2278                end if;
2279             end if;
2280          end;
2281       end if;
2282
2283       List_Linker_Section (Ent);
2284
2285       if List_Representation_Info_To_JSON then
2286          Write_Eol;
2287          Write_Line ("}");
2288       end if;
2289    end List_Type_Info;
2290
2291    ----------------------------
2292    -- Compile_Time_Known_Rep --
2293    ----------------------------
2294
2295    function Compile_Time_Known_Rep (Val : Node_Ref_Or_Val) return Boolean is
2296    begin
2297       return Present (Val) and then Val >= 0;
2298    end Compile_Time_Known_Rep;
2299
2300    ---------------
2301    -- Rep_Value --
2302    ---------------
2303
2304    function Rep_Value (Val : Node_Ref_Or_Val; D : Discrim_List) return Uint is
2305
2306       function B (Val : Boolean) return Ubool;
2307       --  Returns Uint_0 for False, Uint_1 for True
2308
2309       function T (Val : Node_Ref_Or_Val) return Boolean;
2310       --  Returns True for 0, False for any non-zero (i.e. True)
2311
2312       function V (Val : Node_Ref_Or_Val) return Uint;
2313       --  Internal recursive routine to evaluate tree
2314
2315       function W (Val : Uint) return Word;
2316       --  Convert Val to Word, assuming Val is always in the Int range. This
2317       --  is a helper function for the evaluation of bitwise expressions like
2318       --  Bit_And_Expr, for which there is no direct support in uintp. Uint
2319       --  values out of the Int range are expected to be seen in such
2320       --  expressions only with overflowing byte sizes around, introducing
2321       --  inherent unreliabilities in computations anyway.
2322
2323       -------
2324       -- B --
2325       -------
2326
2327       function B (Val : Boolean) return Ubool is
2328       begin
2329          if Val then
2330             return Uint_1;
2331          else
2332             return Uint_0;
2333          end if;
2334       end B;
2335
2336       -------
2337       -- T --
2338       -------
2339
2340       function T (Val : Node_Ref_Or_Val) return Boolean is
2341       begin
2342          if V (Val) = 0 then
2343             return False;
2344          else
2345             return True;
2346          end if;
2347       end T;
2348
2349       -------
2350       -- V --
2351       -------
2352
2353       function V (Val : Node_Ref_Or_Val) return Uint is
2354          L, R, Q : Uint;
2355
2356       begin
2357          if Val >= 0 then
2358             return Val;
2359
2360          else
2361             declare
2362                Node : Exp_Node renames Rep_Table.Table (-UI_To_Int (Val));
2363
2364             begin
2365                case Node.Expr is
2366                   when Cond_Expr =>
2367                      if T (Node.Op1) then
2368                         return V (Node.Op2);
2369                      else
2370                         return V (Node.Op3);
2371                      end if;
2372
2373                   when Plus_Expr =>
2374                      return V (Node.Op1) + V (Node.Op2);
2375
2376                   when Minus_Expr =>
2377                      return V (Node.Op1) - V (Node.Op2);
2378
2379                   when Mult_Expr =>
2380                      return V (Node.Op1) * V (Node.Op2);
2381
2382                   when Trunc_Div_Expr =>
2383                      return V (Node.Op1) / V (Node.Op2);
2384
2385                   when Ceil_Div_Expr =>
2386                      return
2387                        UR_Ceiling
2388                          (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
2389
2390                   when Floor_Div_Expr =>
2391                      return
2392                        UR_Floor
2393                          (V (Node.Op1) / UR_From_Uint (V (Node.Op2)));
2394
2395                   when Trunc_Mod_Expr =>
2396                      return V (Node.Op1) rem V (Node.Op2);
2397
2398                   when Floor_Mod_Expr =>
2399                      return V (Node.Op1) mod V (Node.Op2);
2400
2401                   when Ceil_Mod_Expr =>
2402                      L := V (Node.Op1);
2403                      R := V (Node.Op2);
2404                      Q := UR_Ceiling (L / UR_From_Uint (R));
2405                      return L - R * Q;
2406
2407                   when Exact_Div_Expr =>
2408                      return V (Node.Op1) / V (Node.Op2);
2409
2410                   when Negate_Expr =>
2411                      return -V (Node.Op1);
2412
2413                   when Min_Expr =>
2414                      return UI_Min (V (Node.Op1), V (Node.Op2));
2415
2416                   when Max_Expr =>
2417                      return UI_Max (V (Node.Op1), V (Node.Op2));
2418
2419                   when Abs_Expr =>
2420                      return UI_Abs (V (Node.Op1));
2421
2422                   when Truth_And_Expr =>
2423                      return B (T (Node.Op1) and then T (Node.Op2));
2424
2425                   when Truth_Or_Expr =>
2426                      return B (T (Node.Op1) or else T (Node.Op2));
2427
2428                   when Truth_Xor_Expr =>
2429                      return B (T (Node.Op1) xor T (Node.Op2));
2430
2431                   when Truth_Not_Expr =>
2432                      return B (not T (Node.Op1));
2433
2434                   when Bit_And_Expr =>
2435                      L := V (Node.Op1);
2436                      R := V (Node.Op2);
2437                      return UI_From_Int (Int (W (L) and W (R)));
2438
2439                   when Lt_Expr =>
2440                      return B (V (Node.Op1) < V (Node.Op2));
2441
2442                   when Le_Expr =>
2443                      return B (V (Node.Op1) <= V (Node.Op2));
2444
2445                   when Gt_Expr =>
2446                      return B (V (Node.Op1) > V (Node.Op2));
2447
2448                   when Ge_Expr =>
2449                      return B (V (Node.Op1) >= V (Node.Op2));
2450
2451                   when Eq_Expr =>
2452                      return B (V (Node.Op1) = V (Node.Op2));
2453
2454                   when Ne_Expr =>
2455                      return B (V (Node.Op1) /= V (Node.Op2));
2456
2457                   when Discrim_Val =>
2458                      declare
2459                         Sub : constant Int := UI_To_Int (Node.Op1);
2460                      begin
2461                         pragma Assert (Sub in D'Range);
2462                         return D (Sub);
2463                      end;
2464
2465                   when Dynamic_Val =>
2466                      return No_Uint;
2467                end case;
2468             end;
2469          end if;
2470       end V;
2471
2472       -------
2473       -- W --
2474       -------
2475
2476       --  We use an unchecked conversion to map Int values to their Word
2477       --  bitwise equivalent, which we could not achieve with a normal type
2478       --  conversion for negative Ints. We want bitwise equivalents because W
2479       --  is used as a helper for bit operators like Bit_And_Expr, and can be
2480       --  called for negative Ints in the context of aligning expressions like
2481       --  X+Align & -Align.
2482
2483       function W (Val : Uint) return Word is
2484          function To_Word is new Ada.Unchecked_Conversion (Int, Word);
2485       begin
2486          return To_Word (UI_To_Int (Val));
2487       end W;
2488
2489    --  Start of processing for Rep_Value
2490
2491    begin
2492       if No (Val) then
2493          return No_Uint;
2494
2495       else
2496          return V (Val);
2497       end if;
2498    end Rep_Value;
2499
2500    ------------
2501    -- Spaces --
2502    ------------
2503
2504    procedure Spaces (N : Natural) is
2505    begin
2506       for J in 1 .. N loop
2507          Write_Char (' ');
2508       end loop;
2509    end Spaces;
2510
2511    ---------------------
2512    -- Write_Info_Line --
2513    ---------------------
2514
2515    procedure Write_Info_Line (S : String) is
2516    begin
2517       Write_Repinfo_Line (S (S'First .. S'Last - 1));
2518    end Write_Info_Line;
2519
2520    ---------------------
2521    -- Write_Mechanism --
2522    ---------------------
2523
2524    procedure Write_Mechanism (M : Mechanism_Type) is
2525    begin
2526       case M is
2527          when 0 =>
2528             Write_Str ("default");
2529
2530          when -1 =>
2531             Write_Str ("copy");
2532
2533          when -2 =>
2534             Write_Str ("reference");
2535
2536          when others =>
2537             raise Program_Error;
2538       end case;
2539    end Write_Mechanism;
2540
2541    ---------------------
2542    -- Write_Separator --
2543    ---------------------
2544
2545    procedure Write_Separator is
2546    begin
2547       if Need_Separator then
2548          if List_Representation_Info_To_JSON then
2549             Write_Line (",");
2550          else
2551             Write_Eol;
2552          end if;
2553       else
2554          Need_Separator := True;
2555       end if;
2556    end Write_Separator;
2557
2558    -----------------------
2559    -- Write_Unknown_Val --
2560    -----------------------
2561
2562    procedure Write_Unknown_Val is
2563    begin
2564       if List_Representation_Info_To_JSON then
2565          Write_Str ("""??""");
2566       else
2567          Write_Str ("??");
2568       end if;
2569    end Write_Unknown_Val;
2570
2571    ---------------
2572    -- Write_Val --
2573    ---------------
2574
2575    procedure Write_Val (Val : Node_Ref_Or_Val; Paren : Boolean := False) is
2576    begin
2577       if Compile_Time_Known_Rep (Val) then
2578          UI_Write (Val, Decimal);
2579       elsif List_Representation_Info < 3 or else No (Val) then
2580          Write_Unknown_Val;
2581       else
2582          if Paren then
2583             Write_Char ('(');
2584          end if;
2585
2586          List_GCC_Expression (Val);
2587
2588          if Paren then
2589             Write_Char (')');
2590          end if;
2591       end if;
2592    end Write_Val;
2593
2594 end Repinfo;