gcc/ada/gen_il-gen.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                            G E N _ I L . G E N                           --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2020-2023, 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 Ada.Containers; use type Ada.Containers.Count_Type;
  27 with Ada.Text_IO;
  28
  29 package body Gen_IL.Gen is
  30
  31    Statistics_Enabled : constant Boolean := False;
  32    --  Change to True or False to enable/disable statistics printed by
  33    --  Atree. Should normally be False, for efficiency. Also compile with
  34    --  -gnatd.A to get the statistics printed.  Enabling these statistics
  35    --  makes the compiler about 20% slower.
  36
  37    Num_Header_Slots : constant := 3;
  38    --  Number of header slots; the first Num_Header_Slots slots are stored in
  39    --  the header; the rest are dynamically allocated in the Slots table. We
  40    --  need to subtract this off when accessing dynamic slots. The constant
  41    --  Seinfo.N_Head will contain this value. Fields that are allocated in the
  42    --  header slots are quicker to access.
  43    --
  44    --  This number can be adjusted for efficiency. We choose 3 because the
  45    --  minimum node size is 3 slots, and because that causes the size of type
  46    --  Node_Header to be a power of 2. We can't make it zero, however, because
  47    --  C doesn't allow zero-length arrays.
  48
  49    N_Head : constant String := Image (Field_Offset'(Num_Header_Slots));
  50    --  String form of the above
  51
  52    Enable_Assertions : constant Boolean := True;
  53    --  True to enable predicates on the _Id types, and preconditions on getters
  54    --  and setters.
  55
  56    Overlay_Fields : constant Boolean := True;
  57    --  False to allocate every field so it doesn't overlay any other fields,
  58    --  which results in enormous nodes. For experimenting and debugging.
  59    --  Should be True in normal operation, for efficiency.
  60
  61    SS : constant := 32; -- slot size in bits
  62    SSS : constant String := Image (Bit_Offset'(SS));
  63
  64    Inline : constant String := "Inline";
  65    --  For experimenting with Inline_Always
  66
  67    Syntactic : Fields_Per_Node_Type :=
  68      (others => (others => False));
  69
  70    Nodes_And_Entities : constant Type_Vector := Node_Kind & Entity_Kind;
  71    All_Entities : constant Type_Vector := To_Vector (Entity_Kind, Length => 1);
  72
  73    procedure Create_Type
  74      (T            : Node_Or_Entity_Type;
  75       Parent       : Opt_Abstract_Type;
  76       Fields       : Field_Sequence;
  77       Nmake_Assert : String);
  78    --  Called by the Create_..._Type procedures exported by this package to
  79    --  create an entry in the Types_Table.
  80
  81    procedure Create_Union_Type
  82      (Root : Root_Type; T : Abstract_Type; Children : Type_Array);
  83    --  Called by Create_Node_Union_Type and Create_Entity_Union_Type to create
  84    --  a union type.
  85
  86    function Create_Field
  87      (Field                 : Field_Enum;
  88       Field_Type            : Type_Enum;
  89       Default_Value         : Field_Default_Value;
  90       Type_Only             : Type_Only_Enum;
  91       Pre, Pre_Get, Pre_Set : String;
  92       Is_Syntactic          : Boolean) return Field_Desc;
  93    --  Called by the Create_..._Field functions exported by this package to
  94    --  create an entry in the Field_Table. See Create_Syntactic_Field and
  95    --  Create_Semantic_Field for additional doc.
  96
  97    procedure Check_Type (T : Node_Or_Entity_Type);
  98    --  Check some "legality" rules for types in the Gen_IL little language
  99
 100    ----------------
 101    -- Check_Type --
 102    ----------------
 103
 104    procedure Check_Type (T : Node_Or_Entity_Type) is
 105       Im : constant String := Node_Or_Entity_Type'Image (T);
 106    begin
 107       if Type_Table (T) /= null then
 108          raise Illegal with "duplicate creation of type " & Image (T);
 109       end if;
 110
 111       if T not in Root_Type then
 112          case T is
 113             when Node_Type =>
 114                if Im'Length < 2 or else Im (1 .. 2) /= "N_" then
 115                   raise Illegal with "Node type names must start with ""N_""";
 116                end if;
 117
 118             when Concrete_Entity =>
 119                if Im'Length < 2 or else Im (1 .. 2) /= "E_" then
 120                   raise Illegal with
 121                     "Concrete entity type names must start with ""E_""";
 122                end if;
 123
 124             when others => null;
 125                --  No special prefix for abstract entities
 126          end case;
 127       end if;
 128    end Check_Type;
 129
 130    -----------------
 131    -- Create_Type --
 132    -----------------
 133
 134    procedure Create_Type
 135      (T            : Node_Or_Entity_Type;
 136       Parent       : Opt_Abstract_Type;
 137       Fields       : Field_Sequence;
 138       Nmake_Assert : String)
 139    is
 140    begin
 141       Check_Type (T);
 142
 143       if T not in Root_Type then
 144          if Type_Table (Parent) = null then
 145             raise Illegal with
 146               "undefined parent type for " &
 147               Image (T) & " (parent is " & Image (Parent) & ")";
 148          end if;
 149
 150          if Type_Table (Parent).Is_Union then
 151             raise Illegal with
 152               "parent type for " &
 153                 Image (T) & " must not be union (" & Image (Parent) & ")";
 154          end if;
 155       end if;
 156
 157       Type_Table (T) :=
 158         new Type_Info'
 159           (Is_Union => False, Parent => Parent,
 160            Children | Concrete_Descendants => Type_Vectors.Empty_Vector,
 161            First | Last | Fields => <>, -- filled in later
 162            Nmake_Assert => new String'(Nmake_Assert));
 163
 164       if Parent /= No_Type then
 165          Append (Type_Table (Parent).Children, T);
 166       end if;
 167
 168       --  Check that syntactic fields precede semantic fields. Note that this
 169       --  check is happening before we compute inherited fields.
 170       --  Exempt Chars and Actions from this rule, for now.
 171
 172       declare
 173          Semantic_Seen : Boolean := False;
 174       begin
 175          for J in Fields'Range loop
 176             if Fields (J).Is_Syntactic then
 177                if Semantic_Seen then
 178                   raise Illegal with
 179                     "syntactic fields must precede semantic ones " & Image (T);
 180                end if;
 181
 182             else
 183                if Fields (J).F not in Chars | Actions then
 184                   Semantic_Seen := True;
 185                end if;
 186             end if;
 187          end loop;
 188       end;
 189
 190       --  Check that node fields are in nodes, and entity fields are in
 191       --  entities.
 192
 193       for J in Fields'Range loop
 194          declare
 195             Field : constant Field_Enum := Fields (J).F;
 196             Error_Prefix : constant String :=
 197               "Field " & Image (T) & "." & Image (Field) & " not in ";
 198          begin
 199             case T is
 200                when Node_Type =>
 201                   if Field not in Node_Field then
 202                      raise Illegal with Error_Prefix & "Node_Field";
 203                   end if;
 204
 205                when Entity_Type =>
 206                   if Field not in Entity_Field then
 207                      raise Illegal with Error_Prefix & "Entity_Field";
 208                   end if;
 209
 210                when Type_Boundaries =>
 211                   raise Program_Error; -- dummy types shouldn't have fields
 212             end case;
 213          end;
 214       end loop;
 215
 216       --  Compute the Have_This_Field component of fields, the Fields component
 217       --  of the current type, and Syntactic table.
 218
 219       for J in Fields'Range loop
 220          declare
 221             Field : constant Field_Enum := Fields (J).F;
 222             Is_Syntactic : constant Boolean := Fields (J).Is_Syntactic;
 223
 224          begin
 225             Append (Field_Table (Field).Have_This_Field, T);
 226             Append (Type_Table (T).Fields, Field);
 227
 228             pragma Assert (not Syntactic (T) (Field));
 229             Syntactic (T) (Field) := Is_Syntactic;
 230          end;
 231       end loop;
 232    end Create_Type;
 233
 234    --  Other than constraint checks on T at the call site, and the lack of a
 235    --  parent for root types, the following six all do the same thing.
 236
 237    ---------------------------
 238    -- Create_Root_Node_Type --
 239    ---------------------------
 240
 241    procedure Create_Root_Node_Type
 242      (T      : Abstract_Node;
 243       Fields : Field_Sequence := No_Fields) is
 244    begin
 245       Create_Type (T, Parent => No_Type, Fields => Fields, Nmake_Assert => "");
 246    end Create_Root_Node_Type;
 247
 248    -------------------------------
 249    -- Create_Abstract_Node_Type --
 250    -------------------------------
 251
 252    procedure Create_Abstract_Node_Type
 253      (T      : Abstract_Node; Parent : Abstract_Type;
 254       Fields : Field_Sequence := No_Fields)
 255    is
 256    begin
 257       Create_Type (T, Parent, Fields, Nmake_Assert => "");
 258    end Create_Abstract_Node_Type;
 259
 260    -------------------------------
 261    -- Create_Concrete_Node_Type --
 262    -------------------------------
 263
 264    procedure Create_Concrete_Node_Type
 265      (T      : Concrete_Node; Parent : Abstract_Type;
 266       Fields : Field_Sequence := No_Fields;
 267       Nmake_Assert : String := "")
 268    is
 269    begin
 270       Create_Type (T, Parent, Fields, Nmake_Assert);
 271    end Create_Concrete_Node_Type;
 272
 273    -----------------------------
 274    -- Create_Root_Entity_Type --
 275    -----------------------------
 276
 277    procedure Create_Root_Entity_Type
 278      (T      : Abstract_Entity;
 279       Fields : Field_Sequence := No_Fields) is
 280    begin
 281       Create_Type (T, Parent => No_Type, Fields => Fields, Nmake_Assert => "");
 282    end Create_Root_Entity_Type;
 283
 284    ---------------------------------
 285    -- Create_Abstract_Entity_Type --
 286    ---------------------------------
 287
 288    procedure Create_Abstract_Entity_Type
 289      (T      : Abstract_Entity; Parent : Abstract_Type;
 290       Fields : Field_Sequence := No_Fields)
 291    is
 292    begin
 293       Create_Type (T, Parent, Fields, Nmake_Assert => "");
 294    end Create_Abstract_Entity_Type;
 295
 296    ---------------------------------
 297    -- Create_Concrete_Entity_Type --
 298    ---------------------------------
 299
 300    procedure Create_Concrete_Entity_Type
 301      (T      : Concrete_Entity; Parent : Abstract_Type;
 302       Fields : Field_Sequence := No_Fields)
 303    is
 304    begin
 305       Create_Type (T, Parent, Fields, Nmake_Assert => "");
 306    end Create_Concrete_Entity_Type;
 307
 308    ------------------
 309    -- Create_Field --
 310    ------------------
 311
 312    function Create_Field
 313      (Field                 : Field_Enum;
 314       Field_Type            : Type_Enum;
 315       Default_Value         : Field_Default_Value;
 316       Type_Only             : Type_Only_Enum;
 317       Pre, Pre_Get, Pre_Set : String;
 318       Is_Syntactic          : Boolean) return Field_Desc
 319    is
 320    begin
 321       --  Note that this function has the side effect of update the
 322       --  Field_Table.
 323
 324       pragma Assert (if Default_Value /= No_Default then Is_Syntactic);
 325       pragma Assert (if Type_Only /= No_Type_Only then not Is_Syntactic);
 326
 327       --  First time this field has been seen; create an entry in the
 328       --  Field_Table.
 329
 330       if Field_Table (Field) = null then
 331          Field_Table (Field) := new Field_Info'
 332            (Type_Vectors.Empty_Vector, Field_Type, Default_Value, Type_Only,
 333             Pre => new String'(Pre),
 334             Pre_Get => new String'(Pre_Get),
 335             Pre_Set => new String'(Pre_Set),
 336             Offset => Unknown_Offset);
 337
 338       --  The Field_Table entry has already been created by the 'then' part
 339       --  above. Now we're seeing the same field being "created" again in a
 340       --  different type. Here we check consistency of this new Create_Field
 341       --  call with the old one.
 342
 343       else
 344          if Field_Type /= Field_Table (Field).Field_Type then
 345             raise Illegal with
 346               "mismatched field types for " & Image (Field);
 347          end if;
 348
 349          --  Check that default values for syntactic fields match. This check
 350          --  could be stricter; it currently allows a field to have No_Default
 351          --  in one type, but something else in another type. In that case, we
 352          --  use the "something else" for all types.
 353          --
 354          --  Note that the order of calls does not matter; a default value
 355          --  always overrides a No_Default value.
 356
 357          if Is_Syntactic then
 358             if Default_Value /= Field_Table (Field).Default_Value then
 359                if Field_Table (Field).Default_Value = No_Default then
 360                   Field_Table (Field).Default_Value := Default_Value;
 361                else
 362                   raise Illegal with
 363                     "mismatched default values for " & Image (Field);
 364                end if;
 365             end if;
 366          end if;
 367
 368          if Type_Only /= Field_Table (Field).Type_Only then
 369             raise Illegal with "mismatched Type_Only for " & Image (Field);
 370          end if;
 371
 372          if Pre /= Field_Table (Field).Pre.all then
 373             raise Illegal with
 374               "mismatched extra preconditions for " & Image (Field);
 375          end if;
 376
 377          if Pre_Get /= Field_Table (Field).Pre_Get.all then
 378             raise Illegal with
 379               "mismatched extra getter-only preconditions for " &
 380               Image (Field);
 381          end if;
 382
 383          if Pre_Set /= Field_Table (Field).Pre_Set.all then
 384             raise Illegal with
 385               "mismatched extra setter-only preconditions for " &
 386               Image (Field);
 387          end if;
 388       end if;
 389
 390       return (Field, Is_Syntactic);
 391    end Create_Field;
 392
 393    ----------------------------
 394    -- Create_Syntactic_Field --
 395    ----------------------------
 396
 397    function Create_Syntactic_Field
 398      (Field      : Node_Field;
 399       Field_Type : Type_Enum;
 400       Default_Value : Field_Default_Value := No_Default;
 401       Pre, Pre_Get, Pre_Set : String := "") return Field_Desc
 402    is
 403    begin
 404       return Create_Field
 405         (Field, Field_Type, Default_Value, No_Type_Only,
 406          Pre, Pre_Get, Pre_Set,
 407          Is_Syntactic => True);
 408    end Create_Syntactic_Field;
 409
 410    ---------------------------
 411    -- Create_Semantic_Field --
 412    ---------------------------
 413
 414    function Create_Semantic_Field
 415      (Field      : Field_Enum;
 416       Field_Type : Type_Enum;
 417       Type_Only  : Type_Only_Enum := No_Type_Only;
 418       Pre, Pre_Get, Pre_Set : String := "") return Field_Desc
 419    is
 420    begin
 421       return Create_Field
 422         (Field, Field_Type, No_Default, Type_Only,
 423          Pre, Pre_Get, Pre_Set,
 424          Is_Syntactic => False);
 425    end Create_Semantic_Field;
 426
 427    -----------------------
 428    -- Create_Union_Type --
 429    -----------------------
 430
 431    procedure Create_Union_Type
 432      (Root : Root_Type; T : Abstract_Type; Children : Type_Array)
 433    is
 434       Children_Seen : Type_Set := (others => False);
 435
 436    begin
 437       Check_Type (T);
 438
 439       if Children'Length <= 1 then
 440          raise Illegal with Image (T) & " must have two or more children";
 441       end if;
 442
 443       for Child of Children loop
 444          if Children_Seen (Child) then
 445             raise Illegal with
 446               Image (T) & " has duplicate child " & Image (Child);
 447          end if;
 448
 449          Children_Seen (Child) := True;
 450
 451          if Type_Table (Child) = null then
 452             raise Illegal with
 453               "undefined child type for " &
 454               Image (T) & " (child is " & Image (Child) & ")";
 455          end if;
 456       end loop;
 457
 458       Type_Table (T) :=
 459         new Type_Info'
 460           (Is_Union => True, Parent => Root,
 461            Children | Concrete_Descendants => Type_Vectors.Empty_Vector);
 462
 463       for Child of Children loop
 464          Append (Type_Table (T).Children, Child);
 465       end loop;
 466    end Create_Union_Type;
 467
 468    ----------------------------
 469    -- Create_Node_Union_Type --
 470    ----------------------------
 471
 472    procedure Create_Node_Union_Type
 473      (T : Abstract_Node; Children : Type_Array) is
 474    begin
 475       Create_Union_Type (Node_Kind, T, Children);
 476    end Create_Node_Union_Type;
 477
 478    ------------------------------
 479    -- Create_Entity_Union_Type --
 480    ------------------------------
 481
 482    procedure Create_Entity_Union_Type
 483      (T : Abstract_Entity; Children : Type_Array) is
 484    begin
 485       Create_Union_Type (Entity_Kind, T, Children);
 486    end Create_Entity_Union_Type;
 487
 488    -------------
 489    -- Compile --
 490    -------------
 491
 492    procedure Compile is
 493       Fields_Per_Node : Fields_Per_Node_Type := (others => (others => False));
 494
 495       Type_Bit_Size : array (Concrete_Type) of Bit_Offset := (others => 0);
 496       Min_Node_Bit_Size : Bit_Offset := Bit_Offset'Last;
 497       Max_Node_Bit_Size : Bit_Offset := 0;
 498       Min_Entity_Bit_Size : Bit_Offset := Bit_Offset'Last;
 499       Max_Entity_Bit_Size : Bit_Offset := 0;
 500       --  Above are in units of bits; following are in units of slots:
 501       Min_Node_Size : Field_Offset := Field_Offset'Last;
 502       Max_Node_Size : Field_Offset := 0;
 503       Min_Entity_Size : Field_Offset := Field_Offset'Last;
 504       Max_Entity_Size : Field_Offset := 0;
 505
 506       Node_Field_Types_Used, Entity_Field_Types_Used : Type_Set;
 507
 508       Setter_Needs_Parent : Field_Set :=
 509         (Actions | Expression | Then_Actions | Else_Actions => True,
 510          others => False);
 511       --  Set of fields where the setter should set the Parent. True for
 512       --  syntactic fields of type Node_Id and List_Id, but with some
 513       --  exceptions. Expression is syntactic AND semantic, and the Parent
 514       --  is needed. Default_Expression is also both, but the Parent is not
 515       --  needed. Then_Actions and Else_Actions are not syntactic, but the
 516       --  Parent is needed.
 517
 518       procedure Check_Completeness;
 519       --  Check that every type and field has been declared
 520
 521       procedure Compute_Ranges (Root : Root_Type);
 522       --  Compute the range of Node_Kind/Entity_Kind values for all the types
 523       --  rooted at Root. The result is stored in the First and Last components
 524       --  in the Type_Table.
 525
 526       procedure Compute_Fields_Per_Node;
 527       --  Compute which fields are in which nodes. Implements inheritance of
 528       --  fields. Set the Fields component of each Type_Info to include
 529       --  inherited ones. Set the Is_Syntactic component in the Type_Table to
 530       --  the set of fields that are syntactic in that node kind. Set the
 531       --  Fields_Per_Node table.
 532
 533       procedure Compute_Field_Offsets;
 534       --  Compute the offsets of each field. The results are stored in the
 535       --  Offset components in the Field_Table.
 536
 537       procedure Compute_Type_Sizes;
 538       --  Compute the size of each node and entity type, which is one more than
 539       --  the maximum bit offset of all fields of the type. Results are
 540       --  returned in the above Type_Bit_Size and Min_.../Max_... variables.
 541
 542       procedure Check_For_Syntactic_Field_Mismatch;
 543       --  Check that fields are either all syntactic or all semantic in all
 544       --  nodes in which they exist, except for some fields that already
 545       --  violate this rule.
 546       --
 547       --  Also sets Setter_Needs_Parent.
 548
 549       function Field_Types_Used (First, Last : Field_Enum) return Type_Set;
 550       --  Returns the union of the types of all the fields in the range First
 551       --  .. Last. Only Special_Type; if the declared type of a field is a
 552       --  descendant of Node_Kind or Entity_Kind, then the low-level getter for
 553       --  Node_Id can be used.
 554
 555       procedure Put_Seinfo;
 556       --  Print out the Seinfo package, which is with'ed by both Sinfo.Nodes
 557       --  and Einfo.Entities.
 558
 559       procedure Put_Nodes;
 560       --  Print out the Sinfo.Nodes package spec and body
 561
 562       procedure Put_Entities;
 563       --  Print out the Einfo.Entities package spec and body
 564
 565       procedure Put_Type_And_Subtypes
 566         (S : in out Sink; Root : Root_Type);
 567       --  Called by Put_Nodes and Put_Entities to print out the main type
 568       --  and subtype declarations in Sinfo.Nodes and Einfo.Entities.
 569
 570       procedure Put_Subp_Decls (S : in out Sink; Root : Root_Type);
 571       --  Called by Put_Nodes and Put_Entities to print out the subprogram
 572       --  declarations in Sinfo.Nodes and Einfo.Entities.
 573
 574       procedure Put_Subp_Bodies (S : in out Sink; Root : Root_Type);
 575       --  Called by Put_Nodes and Put_Entities to print out the subprogram
 576       --  bodies in Sinfo.Nodes and Einfo.Entities.
 577
 578       function Node_To_Fetch_From (F : Field_Enum) return String;
 579       --  Name of the Node from which a getter should fetch the value.
 580       --  Normally, we fetch from the node or entity passed in (i.e. formal
 581       --  parameter N). But if Type_Only was specified, we need to fetch the
 582       --  corresponding base (etc) type.
 583
 584       procedure Put_Getter_Spec (S : in out Sink; F : Field_Enum);
 585       procedure Put_Setter_Spec (S : in out Sink; F : Field_Enum);
 586       procedure Put_Getter_Decl (S : in out Sink; F : Field_Enum);
 587       procedure Put_Setter_Decl (S : in out Sink; F : Field_Enum);
 588       procedure Put_Getter_Setter_Locals
 589         (S : in out Sink; F : Field_Enum; Get : Boolean);
 590       procedure Put_Getter_Body (S : in out Sink; F : Field_Enum);
 591       procedure Put_Setter_Body (S : in out Sink; F : Field_Enum);
 592       --  Print out the specification, declaration, or body of a getter or
 593       --  setter for the given field.
 594
 595       procedure Put_Precondition
 596         (S : in out Sink; F : Field_Enum);
 597       --  Print out the precondition, if any, for a getter or setter for the
 598       --  given field.
 599
 600       procedure Put_Casts
 601         (S : in out Sink; T : Type_Enum);
 602       --  Print out the Cast functions for a given type
 603
 604       procedure Put_Traversed_Fields (S : in out Sink);
 605       --  Called by Put_Nodes to print out the Traversed_Fields table in
 606       --  Sinfo.Nodes.
 607
 608       procedure Put_Tables (S : in out Sink; Root : Root_Type);
 609       --  Called by Put_Nodes and Put_Entities to print out the various tables
 610       --  in Sinfo.Nodes and Einfo.Entities.
 611
 612       procedure Put_Nmake;
 613       --  Print out the Nmake package spec and body, containing
 614       --  Make_... functions for each concrete node type.
 615
 616       procedure Put_Make_Decls (S : in out Sink; Root : Root_Type);
 617       --  Called by Put_Nmake to print out the Make_... function declarations
 618
 619       procedure Put_Make_Bodies (S : in out Sink; Root : Root_Type);
 620       --  Called by Put_Nmake to print out the Make_... function bodies
 621
 622       procedure Put_Make_Spec
 623         (S : in out Sink; Root : Root_Type; T : Concrete_Type);
 624       --  Called by Put_Make_Decls and Put_Make_Bodies to print out the spec of
 625       --  a single Make_... function.
 626
 627       procedure Put_Seinfo_Tables;
 628       --  This puts information about both sinfo and einfo.
 629       --  Not actually needed by the compiler.
 630
 631       procedure Put_Sinfo_Dot_H;
 632       --  Print out the sinfo.h file
 633
 634       procedure Put_Einfo_Dot_H;
 635       --  Print out the einfo.h file
 636
 637       procedure Put_C_Type_And_Subtypes
 638         (S : in out Sink; Root : Root_Type);
 639       --  Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out the C code
 640       --  corresponding to the Ada Node_Kind, Entity_Kind, and subtypes
 641       --  thereof.
 642
 643       procedure Put_C_Getters
 644         (S : in out Sink; Root : Root_Type);
 645       --  Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out high-level
 646       --  getters.
 647
 648       procedure Put_C_Getter
 649         (S : in out Sink; F : Field_Enum);
 650       --  Used by Put_C_Getters to print out one high-level getter.
 651
 652       procedure Put_Union_Membership
 653         (S : in out Sink; Root : Root_Type; Only_Prototypes : Boolean);
 654       --  Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out functions to
 655       --  test membership in a union type.
 656
 657       ------------------------
 658       -- Check_Completeness --
 659       ------------------------
 660
 661       procedure Check_Completeness is
 662       begin
 663          for T in Node_Or_Entity_Type loop
 664             if Type_Table (T) = null and then T not in Type_Boundaries then
 665                raise Illegal with "Missing type declaration for " & Image (T);
 666             end if;
 667          end loop;
 668
 669          for F in Field_Enum loop
 670             if Field_Table (F) = null
 671               and then F /= Between_Node_And_Entity_Fields
 672             then
 673                raise Illegal with "Missing field declaration for " & Image (F);
 674             end if;
 675          end loop;
 676       end Check_Completeness;
 677
 678       --------------------
 679       -- Compute_Ranges --
 680       --------------------
 681
 682       procedure Compute_Ranges (Root : Root_Type) is
 683
 684          procedure Do_One_Type (T : Node_Or_Entity_Type);
 685          --  Compute the range for one type. Passed to Iterate_Types to process
 686          --  all of them.
 687
 688          procedure Add_Concrete_Descendant_To_Ancestors
 689            (Ancestor : Abstract_Type; Descendant : Concrete_Type);
 690          --  Add Descendant to the Concrete_Descendants of each of its
 691          --  ancestors.
 692
 693          procedure Add_Concrete_Descendant_To_Ancestors
 694            (Ancestor : Abstract_Type; Descendant : Concrete_Type) is
 695          begin
 696             if Ancestor not in Root_Type then
 697                Add_Concrete_Descendant_To_Ancestors
 698                  (Type_Table (Ancestor).Parent, Descendant);
 699             end if;
 700
 701             Append (Type_Table (Ancestor).Concrete_Descendants, Descendant);
 702          end Add_Concrete_Descendant_To_Ancestors;
 703
 704          procedure Do_One_Type (T : Node_Or_Entity_Type) is
 705          begin
 706             case T is
 707                when Concrete_Type =>
 708                   pragma Annotate (Codepeer, Modified, Type_Table);
 709                   Type_Table (T).First := T;
 710                   Type_Table (T).Last  := T;
 711                   Add_Concrete_Descendant_To_Ancestors
 712                     (Type_Table (T).Parent, T);
 713                   --  Parent cannot be No_Type here, because T is a concrete
 714                   --  type, and therefore not a root type.
 715
 716                when Abstract_Type =>
 717                   declare
 718                      Children : Type_Vector renames Type_Table (T).Children;
 719                   begin
 720                      --  Ensure that an abstract type is not a leaf in the type
 721                      --  hierarchy.
 722
 723                      if Is_Empty (Children) then
 724                         raise Illegal with Image (T) & " has no children";
 725                      end if;
 726
 727                      --  We could support abstract types with only one child,
 728                      --  but what's the point of having such a type?
 729
 730                      if Last_Index (Children) = 1 then
 731                         raise Illegal with Image (T) & " has only one child";
 732                      end if;
 733
 734                      Type_Table (T).First := Type_Table (Children (1)).First;
 735                      Type_Table (T).Last  :=
 736                        Type_Table (Children (Last_Index (Children))).Last;
 737                   end;
 738
 739                when Between_Abstract_Entity_And_Concrete_Node_Types =>
 740                   raise Program_Error;
 741             end case;
 742          end Do_One_Type;
 743       begin
 744          Iterate_Types (Root, Post => Do_One_Type'Access);
 745       end Compute_Ranges;
 746
 747       -----------------------------
 748       -- Compute_Fields_Per_Node --
 749       -----------------------------
 750
 751       procedure Compute_Fields_Per_Node is
 752
 753          Duplicate_Fields_Found : Boolean := False;
 754
 755          function Get_Fields (T : Node_Or_Entity_Type) return Field_Vector;
 756          --  Compute the fields of a given type. This is the fields inherited
 757          --  from ancestors, plus the fields declared for the type itself.
 758
 759          function Get_Syntactic_Fields
 760            (T : Node_Or_Entity_Type) return Field_Set;
 761          --  Compute the set of fields that are syntactic for a given type.
 762          --  Note that a field can be syntactic in some node types, but
 763          --  semantic in others.
 764
 765          procedure Do_Concrete_Type (CT : Concrete_Type);
 766          --  Do the Compute_Fields_Per_Node work for a concrete type
 767
 768          function Get_Fields (T : Node_Or_Entity_Type) return Field_Vector is
 769             Parent_Fields : constant Field_Vector :=
 770               (if T in Root_Type then Field_Vectors.Empty_Vector
 771                else Get_Fields (Type_Table (T).Parent));
 772          begin
 773             return Parent_Fields & Type_Table (T).Fields;
 774          end Get_Fields;
 775
 776          function Get_Syntactic_Fields
 777            (T : Node_Or_Entity_Type) return Field_Set
 778          is
 779             Parent_Is_Syntactic : constant Field_Set :=
 780               (if T in Root_Type then (Field_Enum => False)
 781                else Get_Syntactic_Fields (Type_Table (T).Parent));
 782          begin
 783             return Parent_Is_Syntactic or Syntactic (T);
 784          end Get_Syntactic_Fields;
 785
 786          procedure Do_Concrete_Type (CT : Concrete_Type) is
 787          begin
 788             Type_Table (CT).Fields := Get_Fields (CT);
 789             Syntactic (CT) := Get_Syntactic_Fields (CT);
 790
 791             for F of Type_Table (CT).Fields loop
 792                if Fields_Per_Node (CT) (F) then
 793                   Ada.Text_IO.Put_Line
 794                     ("duplicate field" & Image (CT) & Image (F));
 795                   Duplicate_Fields_Found := True;
 796                end if;
 797
 798                Fields_Per_Node (CT) (F) := True;
 799             end loop;
 800          end Do_Concrete_Type;
 801
 802       begin -- Compute_Fields_Per_Node
 803          for CT in Concrete_Node loop
 804             Do_Concrete_Type (CT);
 805          end loop;
 806
 807          --  The node fields defined for all three N_Entity kinds should be the
 808          --  same:
 809
 810          if Type_Table (N_Defining_Character_Literal).Fields /=
 811            Type_Table (N_Defining_Identifier).Fields
 812          then
 813             raise Illegal with
 814               "fields for N_Defining_Identifier and " &
 815               "N_Defining_Character_Literal must match";
 816          end if;
 817
 818          if Type_Table (N_Defining_Operator_Symbol).Fields /=
 819            Type_Table (N_Defining_Identifier).Fields
 820          then
 821             raise Illegal with
 822               "fields for N_Defining_Identifier and " &
 823               "N_Defining_Operator_Symbol must match";
 824          end if;
 825
 826          if Fields_Per_Node (N_Defining_Character_Literal) /=
 827            Fields_Per_Node (N_Defining_Identifier)
 828          then
 829             raise Illegal with
 830               "Fields of N_Defining_Character_Literal must match " &
 831               "N_Defining_Identifier";
 832          end if;
 833
 834          if Fields_Per_Node (N_Defining_Operator_Symbol) /=
 835            Fields_Per_Node (N_Defining_Identifier)
 836          then
 837             raise Illegal with
 838               "Fields of N_Defining_Operator_Symbol must match " &
 839               "N_Defining_Identifier";
 840          end if;
 841
 842          --  Copy node fields from N_Entity nodes to entities, so they have
 843          --  slots allocated (but the getters and setters are only in
 844          --  Sinfo.Nodes).
 845
 846          Type_Table (Entity_Kind).Fields :=
 847            Type_Table (N_Defining_Identifier).Fields &
 848            Type_Table (Entity_Kind).Fields;
 849
 850          for CT in Concrete_Entity loop
 851             Do_Concrete_Type (CT);
 852          end loop;
 853
 854          if Duplicate_Fields_Found then
 855             raise Illegal with "duplicate fields found";
 856          end if;
 857       end Compute_Fields_Per_Node;
 858
 859       function Field_Size (T : Type_Enum) return Bit_Offset is
 860         (case T is
 861           when Flag => 1,
 862
 863           when Small_Paren_Count_Type | Component_Alignment_Kind => 2,
 864
 865           when Node_Kind_Type | Entity_Kind_Type | Convention_Id => 8,
 866
 867           when Mechanism_Type
 868              | List_Id
 869              | Elist_Id
 870              | Name_Id
 871              | String_Id
 872              | Uint
 873              | Uint_Subtype
 874              | Ureal
 875              | Source_Ptr
 876              | Union_Id
 877              | Node_Id
 878              | Node_Or_Entity_Type => 32,
 879
 880          when Between_Special_And_Abstract_Node_Types => -- can't happen
 881            Bit_Offset'Last);
 882          --  Size in bits of a a field of type T. It must be a power of 2, and
 883          --  must match the size of the type in GNAT, which sometimes requires
 884          --  a Size clause in GNAT.
 885          --
 886          --  Note that this is not the same as Type_Bit_Size of the field's
 887          --  type. For one thing, Type_Bit_Size only covers concrete node and
 888          --  entity types, which does not include most of the above. For
 889          --  another thing, Type_Bit_Size includes the full size of all the
 890          --  fields, whereas a field of a node or entity type is just a 32-bit
 891          --  Node_Id or Entity_Id; i.e. it is indirect.
 892
 893       function Field_Size (F : Field_Enum) return Bit_Offset is
 894         (Field_Size (Field_Table (F).Field_Type));
 895
 896       function To_Bit_Offset (F : Field_Enum; Offset : Field_Offset'Base)
 897         return Bit_Offset'Base is
 898           (Bit_Offset'Base (Offset) * Field_Size (F));
 899       function First_Bit (F : Field_Enum; Offset : Field_Offset)
 900         return Bit_Offset is
 901           (To_Bit_Offset (F, Offset));
 902       function Last_Bit (F : Field_Enum; Offset : Field_Offset)
 903         return Bit_Offset is
 904           (To_Bit_Offset (F, Offset + 1) - 1);
 905
 906       function To_Size_In_Slots (Size_In_Bits : Bit_Offset)
 907         return Field_Offset is
 908           ((Field_Offset (Size_In_Bits) + (SS - 1)) / SS);
 909
 910       function Type_Size_In_Slots (T : Concrete_Type) return Field_Offset is
 911         (To_Size_In_Slots (Type_Bit_Size (T))); -- rounded up to slot boundary
 912
 913       function Type_Bit_Size_Aligned (T : Concrete_Type) return Bit_Offset is
 914         (Bit_Offset (Type_Size_In_Slots (T)) * SS); -- multiple of slot size
 915
 916       ---------------------------
 917       -- Compute_Field_Offsets --
 918       ---------------------------
 919
 920       procedure Compute_Field_Offsets is
 921          type Offset_Set_Unconstrained is array (Bit_Offset range <>)
 922            of Boolean with Pack;
 923          subtype Offset_Set is Offset_Set_Unconstrained (Bit_Offset);
 924          Offset_Sets : array (Concrete_Type) of Offset_Set :=
 925            (others => (others => False));
 926
 927          function All_False
 928            (F : Field_Enum; Offset : Field_Offset)
 929            return Offset_Set_Unconstrained is
 930              (First_Bit (F, Offset) .. Last_Bit (F, Offset) => False);
 931
 932          function All_True
 933            (F : Field_Enum; Offset : Field_Offset)
 934            return Offset_Set_Unconstrained is
 935              (First_Bit (F, Offset) .. Last_Bit (F, Offset) => True);
 936
 937          function Offset_OK
 938            (F : Field_Enum; Offset : Field_Offset) return Boolean;
 939          --  True if it is OK to choose this offset; that is, if this offset is
 940          --  not in use for any type that has the field. If Overlay_Fields is
 941          --  False, then "any type that has the field" --> "any type, whether
 942          --  or not it has the field".
 943
 944          procedure Set_Offset_In_Use
 945            (F : Field_Enum; Offset : Field_Offset);
 946          --  Mark the offset as "in use"
 947
 948          procedure Choose_Offset (F : Field_Enum);
 949          --  Choose an offset for this field
 950
 951          function Offset_OK
 952            (F : Field_Enum; Offset : Field_Offset) return Boolean is
 953          begin
 954             for T in Concrete_Type loop
 955                if Fields_Per_Node (T) (F) or else not Overlay_Fields then
 956                   declare
 957                      Bits : Offset_Set_Unconstrained renames
 958                        Offset_Sets (T)
 959                          (First_Bit (F, Offset) .. Last_Bit (F, Offset));
 960                   begin
 961                      if Bits /= All_False (F, Offset) then
 962                         return False;
 963                      end if;
 964                   end;
 965                end if;
 966             end loop;
 967
 968             return True;
 969          end Offset_OK;
 970
 971          procedure Set_Offset_In_Use
 972            (F : Field_Enum; Offset : Field_Offset) is
 973          begin
 974             for T in Concrete_Type loop
 975                if Fields_Per_Node (T) (F) then
 976                   declare
 977                      Bits : Offset_Set_Unconstrained renames
 978                        Offset_Sets (T)
 979                          (First_Bit (F, Offset) .. Last_Bit (F, Offset));
 980                   begin
 981                      pragma Assert (Bits = All_False (F, Offset));
 982                      Bits := All_True (F, Offset);
 983                   end;
 984                end if;
 985             end loop;
 986          end Set_Offset_In_Use;
 987
 988          procedure Choose_Offset (F : Field_Enum) is
 989          begin
 990             for Offset in Field_Offset loop
 991                if Offset_OK (F, Offset) then
 992                   Set_Offset_In_Use (F, Offset);
 993
 994                   Field_Table (F).Offset := Offset;
 995                   return;
 996                end if;
 997             end loop;
 998
 999             raise Illegal with "No available field offset for " & Image (F) &
1000               "; need to increase Gen_IL.Internals.Bit_Offset'Last (" &
1001               Image (Gen_IL.Internals.Bit_Offset'Last) & " is too small)";
1002          end Choose_Offset;
1003
1004          Weighted_Node_Frequency : array (Field_Enum) of Type_Count :=
1005            (others => 0);
1006          --  Number of concrete types that have each field
1007
1008          function More_Types_Have_Field (F1, F2 : Field_Enum) return Boolean is
1009            (Weighted_Node_Frequency (F1) > Weighted_Node_Frequency (F2));
1010          --  True if F1 appears in more concrete types than F2
1011
1012          function Sort_Less (F1, F2 : Field_Enum) return Boolean is
1013            (if Weighted_Node_Frequency (F1) = Weighted_Node_Frequency (F2) then
1014               F1 < F2
1015             else More_Types_Have_Field (F1, F2));
1016
1017          package Sorting is new Field_Vectors.Generic_Sorting
1018            ("<" => Sort_Less);
1019
1020          All_Fields : Field_Vector;
1021
1022       --  Start of processing for Compute_Field_Offsets
1023
1024       begin
1025
1026          --  Compute the number of types that have each field, weighted by the
1027          --  frequency of such nodes.
1028
1029          for T in Concrete_Type loop
1030             for F in Field_Enum loop
1031                if Fields_Per_Node (T) (F) then
1032                   Weighted_Node_Frequency (F) :=
1033                     Weighted_Node_Frequency (F) + Type_Frequency (T);
1034                end if;
1035             end loop;
1036          end loop;
1037
1038          --  Collect all the fields in All_Fields
1039
1040          for F in Node_Field loop
1041             Append (All_Fields, F);
1042          end loop;
1043
1044          for F in Entity_Field loop
1045             Append (All_Fields, F);
1046          end loop;
1047
1048          --  Sort All_Fields based on how many concrete types have the field.
1049          --  This is for efficiency; we want to choose the offsets of the most
1050          --  common fields first, so they get low numbers.
1051
1052          Sorting.Sort (All_Fields);
1053
1054          --  Go through all the fields, and choose the lowest offset that is
1055          --  free in all types that have the field. This is basically a
1056          --  graph-coloring algorithm on the interference graph. The
1057          --  interference graph is an undirected graph with the fields being
1058          --  nodes (not nodes in the compiler!) in the graph, and an edge
1059          --  between a pair of fields if they appear in the same node in the
1060          --  compiler. The "colors" are fields offsets, except that a
1061          --  complication compared to standard graph coloring is that fields
1062          --  are different sizes.
1063
1064          --  First choose offsets for some heavily-used fields, so they will
1065          --  get low offsets, so they will wind up in the node header for
1066          --  faster access.
1067
1068          Choose_Offset (Nkind);
1069          pragma Assert (Field_Table (Nkind).Offset = 0);
1070          Choose_Offset (Ekind);
1071          pragma Assert (Field_Table (Ekind).Offset = 1);
1072          Choose_Offset (Homonym);
1073          pragma Assert (Field_Table (Homonym).Offset = 1);
1074          Choose_Offset (Is_Immediately_Visible);
1075          pragma Assert (Field_Table (Is_Immediately_Visible).Offset = 16);
1076          Choose_Offset (From_Limited_With);
1077          pragma Assert (Field_Table (From_Limited_With).Offset = 17);
1078          Choose_Offset (Is_Potentially_Use_Visible);
1079          pragma Assert (Field_Table (Is_Potentially_Use_Visible).Offset = 18);
1080          Choose_Offset (Is_Generic_Instance);
1081          pragma Assert (Field_Table (Is_Generic_Instance).Offset = 19);
1082          Choose_Offset (Scope);
1083          pragma Assert (Field_Table (Scope).Offset = 2);
1084
1085          --  Then loop through them all, skipping the ones we did above
1086
1087          for F of All_Fields loop
1088             if Field_Table (F).Offset = Unknown_Offset then
1089                Choose_Offset (F);
1090             end if;
1091          end loop;
1092
1093       end Compute_Field_Offsets;
1094
1095       ------------------------
1096       -- Compute_Type_Sizes --
1097       ------------------------
1098
1099       procedure Compute_Type_Sizes is
1100       begin
1101          for T in Concrete_Type loop
1102             declare
1103                Max_Offset : Bit_Offset := 0;
1104
1105             begin
1106                for F in Field_Enum loop
1107                   if Fields_Per_Node (T) (F) then
1108                      Max_Offset :=
1109                        Bit_Offset'Max
1110                          (Max_Offset,
1111                           To_Bit_Offset (F, Field_Table (F).Offset));
1112                   end if;
1113                end loop;
1114
1115                --  No type can be smaller than the header slots
1116
1117                Type_Bit_Size (T) :=
1118                  Bit_Offset'Max (Max_Offset + 1, SS * Num_Header_Slots);
1119             end;
1120          end loop;
1121
1122          for T in Concrete_Node loop
1123             Min_Node_Bit_Size :=
1124               Bit_Offset'Min (Min_Node_Bit_Size, Type_Bit_Size (T));
1125             Max_Node_Bit_Size :=
1126               Bit_Offset'Max (Max_Node_Bit_Size, Type_Bit_Size (T));
1127          end loop;
1128
1129          for T in Concrete_Entity loop
1130             Min_Entity_Bit_Size :=
1131               Bit_Offset'Min (Min_Entity_Bit_Size, Type_Bit_Size (T));
1132             Max_Entity_Bit_Size :=
1133               Bit_Offset'Max (Max_Entity_Bit_Size, Type_Bit_Size (T));
1134          end loop;
1135
1136          Min_Node_Size := To_Size_In_Slots (Min_Node_Bit_Size);
1137          Max_Node_Size := To_Size_In_Slots (Max_Node_Bit_Size);
1138          Min_Entity_Size := To_Size_In_Slots (Min_Entity_Bit_Size);
1139          Max_Entity_Size := To_Size_In_Slots (Max_Entity_Bit_Size);
1140       end Compute_Type_Sizes;
1141
1142       ----------------------------------------
1143       -- Check_For_Syntactic_Field_Mismatch --
1144       ----------------------------------------
1145
1146       procedure Check_For_Syntactic_Field_Mismatch is
1147       begin
1148          for F in Field_Enum loop
1149             if F /= Between_Node_And_Entity_Fields then
1150                declare
1151                   Syntactic_Seen, Semantic_Seen : Boolean := False;
1152                   Have_Field : Type_Vector renames
1153                     Field_Table (F).Have_This_Field;
1154
1155                begin
1156                   for J in 1 .. Last_Index (Have_Field) loop
1157                      if Syntactic (Have_Field (J)) (F) then
1158                         Syntactic_Seen := True;
1159                      else
1160                         Semantic_Seen := True;
1161                      end if;
1162                   end loop;
1163
1164                   --  The following fields violate this rule. We might want to
1165                   --  simplify by getting rid of these cases, but we allow them
1166                   --  for now. At least, we don't want to add any new cases of
1167                   --  syntactic/semantic mismatch.
1168
1169                   if F in Chars | Actions | Expression | Default_Expression
1170                   then
1171                      pragma Assert (Syntactic_Seen and Semantic_Seen);
1172
1173                   else
1174                      if Syntactic_Seen and Semantic_Seen then
1175                         raise Illegal with
1176                           "syntactic/semantic mismatch for " & Image (F);
1177                      end if;
1178
1179                      if Field_Table (F).Field_Type in Traversed_Field_Type
1180                        and then Syntactic_Seen
1181                      then
1182                         Setter_Needs_Parent (F) := True;
1183                      end if;
1184                   end if;
1185                end;
1186             end if;
1187          end loop;
1188       end Check_For_Syntactic_Field_Mismatch;
1189
1190       ----------------------
1191       -- Field_Types_Used --
1192       ----------------------
1193
1194       function Field_Types_Used (First, Last : Field_Enum) return Type_Set is
1195          Result : Type_Set := (others => False);
1196       begin
1197          for F in First .. Last loop
1198             if Field_Table (F).Field_Type in Node_Or_Entity_Type then
1199                Result (Node_Id) := True;
1200
1201             --  Subtypes of Uint all use the same Cast for Uint
1202
1203             elsif Field_Table (F).Field_Type in Uint_Subtype then
1204                Result (Uint) := True;
1205
1206             else
1207                Result (Field_Table (F).Field_Type) := True;
1208             end if;
1209          end loop;
1210
1211          return Result;
1212       end Field_Types_Used;
1213
1214       pragma Style_Checks ("M120");
1215       --  Lines of the form Put (S, "..."); are more readable if we relax the
1216       --  line length. We really just want the "..." to be short enough.
1217
1218       ---------------------------
1219       -- Put_Type_And_Subtypes --
1220       ---------------------------
1221
1222       procedure Put_Type_And_Subtypes
1223         (S : in out Sink; Root : Root_Type)
1224       is
1225
1226          procedure Put_Enum_Type;
1227          --  Print out the enumeration type declaration for a root type
1228          --  (Node_Kind or Entity_Kind).
1229
1230          procedure Put_Kind_Subtype (T : Node_Or_Entity_Type);
1231          --  Print out a subrange (of type Node_Kind or Entity_Kind) for a
1232          --  given nonroot abstract type.
1233
1234          procedure Put_Id_Subtype (T : Node_Or_Entity_Type);
1235          --  Print out a subtype (of type Node_Id or Entity_Id) for a given
1236          --  nonroot abstract type.
1237
1238          procedure Put_Opt_Subtype (T : Node_Or_Entity_Type);
1239          --  Print out an "optional" subtype; that is, one that allows
1240          --  Empty. Their names start with "Opt_".
1241
1242          procedure Put_Enum_Type is
1243             procedure Put_Enum_Lit (T : Node_Or_Entity_Type);
1244             --  Print out one enumeration literal in the declaration of
1245             --  Node_Kind or Entity_Kind.
1246
1247             First_Time : Boolean := True;
1248
1249             procedure Put_Enum_Lit (T : Node_Or_Entity_Type) is
1250             begin
1251                if T in Concrete_Type then
1252                   if First_Time then
1253                      First_Time := False;
1254                   else
1255                      Put (S, "," & LF);
1256                   end if;
1257
1258                   Put (S, Image (T));
1259                end if;
1260             end Put_Enum_Lit;
1261
1262             type Dummy is array
1263               (First_Concrete (Root) .. Last_Concrete (Root)) of Boolean;
1264             Num_Types : constant Root_Int := Dummy'Length;
1265
1266          begin
1267             Put (S, "type " & Image (Root) & " is -- " &
1268                     Image (Num_Types) & " " & Image (Root) & "s" & LF);
1269             Increase_Indent (S, 2);
1270             Put (S, "(");
1271             Increase_Indent (S, 1);
1272             Iterate_Types (Root, Pre => Put_Enum_Lit'Access);
1273             Decrease_Indent (S, 1);
1274             Put (S, LF & ") with Size => 8; -- " & Image (Root) & LF & LF);
1275             Decrease_Indent (S, 2);
1276          end Put_Enum_Type;
1277
1278          procedure Put_Kind_Subtype (T : Node_Or_Entity_Type) is
1279          begin
1280             if T in Abstract_Type then
1281                if Type_Table (T).Is_Union then
1282                   pragma Assert (Type_Table (T).Parent = Root);
1283
1284                   Put (S, "subtype " & Image (T) & " is" & LF);
1285                   Increase_Indent (S, 2);
1286                   Put (S, Image (Root) & " with Predicate =>" & LF);
1287                   Increase_Indent (S, 2);
1288                   Put (S, Image (T) & " in" & LF);
1289                   Put_Types_With_Bars (S, Type_Table (T).Children);
1290                   Decrease_Indent (S, 2);
1291                   Put (S, ";" & LF);
1292                   Decrease_Indent (S, 2);
1293
1294                elsif Type_Table (T).Parent /= No_Type then
1295                   Put (S, "subtype " & Image (T) & " is " &
1296                        Image (Type_Table (T).Parent) & " range" & LF);
1297                   Increase_Indent (S, 2);
1298                   Put (S, Image (Type_Table (T).First) & " .. " &
1299                           Image (Type_Table (T).Last) & ";" & LF);
1300                   Decrease_Indent (S, 2);
1301
1302                   Increase_Indent (S, 3);
1303
1304                   for J in 1 .. Type_Table (T).Concrete_Descendants.Last_Index loop
1305                      Put (S, "--  " &
1306                           Image (Type_Table (T).Concrete_Descendants (J)) & LF);
1307                   end loop;
1308
1309                   Decrease_Indent (S, 3);
1310                end if;
1311             end if;
1312          end Put_Kind_Subtype;
1313
1314          procedure Put_Id_Subtype (T : Node_Or_Entity_Type) is
1315          begin
1316             if Type_Table (T).Parent /= No_Type then
1317                Put (S, "subtype " & Id_Image (T) & " is" & LF);
1318                Increase_Indent (S, 2);
1319                Put (S, Id_Image (Type_Table (T).Parent));
1320
1321                if Enable_Assertions then
1322                   Put (S, " with Predicate =>" & LF);
1323                   Increase_Indent (S, 2);
1324                   Put (S, "K (" & Id_Image (T) & ") in " & Image (T));
1325                   Decrease_Indent (S, 2);
1326                end if;
1327
1328                Put (S, ";" & LF);
1329                Decrease_Indent (S, 2);
1330             end if;
1331          end Put_Id_Subtype;
1332
1333          procedure Put_Opt_Subtype (T : Node_Or_Entity_Type) is
1334          begin
1335             if Type_Table (T).Parent /= No_Type then
1336                Put (S, "subtype Opt_" & Id_Image (T) & " is" & LF);
1337                Increase_Indent (S, 2);
1338                Put (S, Id_Image (Root));
1339
1340                --  Assert that the Opt_XXX subtype is empty or in the XXX
1341                --  subtype.
1342
1343                if Enable_Assertions then
1344                   Put (S, " with Predicate =>" & LF);
1345                   Increase_Indent (S, 2);
1346                   Put (S, "Opt_" & Id_Image (T) & " = Empty or else" & LF);
1347                   Put (S, "Opt_" & Id_Image (T) & " in " & Id_Image (T));
1348                   Decrease_Indent (S, 2);
1349                end if;
1350
1351                Put (S, ";" & LF);
1352                Decrease_Indent (S, 2);
1353             end if;
1354          end Put_Opt_Subtype;
1355
1356       begin -- Put_Type_And_Subtypes
1357          Put_Enum_Type;
1358
1359          --  Put the getter for Nkind and Ekind here, earlier than the other
1360          --  getters, because it is needed in predicates of the following
1361          --  subtypes.
1362
1363          case Root is
1364             when Node_Kind =>
1365                Put_Getter_Decl (S, Nkind);
1366                Put (S, "function K (N : Node_Id) return Node_Kind renames " & Image (Nkind) & ";" & LF);
1367                Put (S, "--  Shorthand for use in predicates and preconditions below" & LF);
1368                Put (S, "--  There is no procedure Set_Nkind." & LF);
1369                Put (S, "--  See Init_Nkind and Mutate_Nkind in Atree." & LF & LF);
1370
1371             when Entity_Kind =>
1372                Put_Getter_Decl (S, Ekind);
1373                Put (S, "function K (N : Entity_Id) return Entity_Kind renames Ekind;" & LF);
1374                Put (S, "--  Shorthand for use in predicates and preconditions below" & LF);
1375                Put (S, "--  There is no procedure Set_Ekind here." & LF);
1376                Put (S, "--  See Mutate_Ekind in Atree." & LF & LF);
1377
1378             when others => raise Program_Error;
1379          end case;
1380
1381          Put (S, "--  Subtypes of " & Image (Root) & " for each abstract type:" & LF & LF);
1382
1383          Put (S, "pragma Style_Checks (""M200"");" & LF);
1384          Iterate_Types (Root, Pre => Put_Kind_Subtype'Access);
1385
1386          Put (S, LF & "--  Subtypes of " & Id_Image (Root) &
1387               " with specified " & Image (Root) & "." & LF);
1388          Put (S, "--  These may be used in place of " & Id_Image (Root) &
1389               " for better documentation," & LF);
1390          Put (S, "--  and if assertions are enabled, for run-time checking." & LF & LF);
1391
1392          Iterate_Types (Root, Pre => Put_Id_Subtype'Access);
1393
1394          Put (S, LF & "--  Union types (nonhierarchical subtypes of " &
1395               Id_Image (Root) & ")" & LF & LF);
1396
1397          for T in First_Abstract (Root) .. Last_Abstract (Root) loop
1398             if Type_Table (T) /= null and then Type_Table (T).Is_Union then
1399                Put_Kind_Subtype (T);
1400                Put_Id_Subtype (T);
1401             end if;
1402          end loop;
1403
1404          Put (S, LF & "--  Optional subtypes of " & Id_Image (Root) & "." &
1405               " These allow Empty." & LF & LF);
1406
1407          Iterate_Types (Root, Pre => Put_Opt_Subtype'Access);
1408
1409          Put (S, LF & "--  Optional union types:" & LF & LF);
1410
1411          for T in First_Abstract (Root) .. Last_Abstract (Root) loop
1412             if Type_Table (T) /= null and then Type_Table (T).Is_Union then
1413                Put_Opt_Subtype (T);
1414             end if;
1415          end loop;
1416
1417          Put (S, LF & "subtype Flag is Boolean;" & LF & LF);
1418       end Put_Type_And_Subtypes;
1419
1420       -------------------------------------------
1421       -- Put_Casts --
1422       -------------------------------------------
1423
1424       procedure Put_Casts
1425         (S : in out Sink; T : Type_Enum)
1426       is
1427          Pre : constant String :=
1428            "function Cast is new Ada.Unchecked_Conversion (";
1429          Lo_Type : constant String := "Field_Size_" & Image (Field_Size (T)) & "_Bit";
1430          Hi_Type : constant String := Get_Set_Id_Image (T);
1431       begin
1432          if T not in Uint_Subtype then
1433             if T not in Node_Kind_Type | Entity_Kind_Type then
1434                Put (S, Pre & Hi_Type & ", " & Lo_Type & ");" & LF);
1435             end if;
1436
1437             Put (S, Pre & Lo_Type & ", " & Hi_Type & ");" & LF);
1438          end if;
1439       end Put_Casts;
1440
1441       ----------------------
1442       -- Put_Precondition --
1443       ----------------------
1444
1445       procedure Put_Precondition
1446         (S : in out Sink; F : Field_Enum)
1447       is
1448          --  If the field is present in all entities, we want to assert that
1449          --  N in N_Entity_Id. If the field is present in only some entities,
1450          --  we don't need that, because we are fetching Ekind in that case,
1451          --  which will assert N in N_Entity_Id.
1452
1453          Is_Entity : constant String :=
1454            (if Field_Table (F).Have_This_Field = All_Entities then
1455              "N in N_Entity_Id"
1456             else "");
1457       begin
1458          --  If this is an entity field, then we should assert that N is an
1459          --  entity. We need "N in A | B | ..." unless this is embodied in a
1460          --  subtype predicate.
1461          --
1462          --  We can't put the extra "Pre => ..." specified on the call to
1463          --  Create_..._Field as part of the precondition, because some of
1464          --  them call things that are not visible here.
1465
1466          if Enable_Assertions then
1467             if Length (Field_Table (F).Have_This_Field) = 1
1468               or else Field_Table (F).Have_This_Field = Nodes_And_Entities
1469             then
1470                if Is_Entity /= "" then
1471                   Increase_Indent (S, 1);
1472                   Put (S, ", Pre =>" & LF);
1473                   Put (S, Is_Entity);
1474                   Decrease_Indent (S, 1);
1475                end if;
1476
1477             else
1478                Put (S, ", Pre =>" & LF);
1479                Increase_Indent (S, 1);
1480                Put (S, "N in ");
1481                Put_Type_Ids_With_Bars (S, Field_Table (F).Have_This_Field);
1482
1483                pragma Assert (Is_Entity = "");
1484
1485                Decrease_Indent (S, 1);
1486             end if;
1487          end if;
1488       end Put_Precondition;
1489
1490       function Root_Type_For_Field (F : Field_Enum) return Root_Type is
1491         (case F is
1492            when Node_Field           => Node_Kind,
1493            when Entity_Field         => Entity_Kind,
1494            when Between_Node_And_Entity_Fields => Node_Kind); -- can't happen
1495
1496       function N_Type (F : Field_Enum) return String is
1497         (if Length (Field_Table (F).Have_This_Field) = 1 then
1498           Id_Image (Field_Table (F).Have_This_Field (1))
1499          else Id_Image (Root_Type_For_Field (F)));
1500       --  Name of the parameter type of the N parameter of the getter and
1501       --  setter for field F. If there's only one Have_This_Field, use that;
1502       --  the predicate will check for the right Kind. Otherwise, we use
1503       --  Node_Id or Entity_Id, and the getter and setter will have
1504       --  preconditions.
1505
1506       procedure Put_Get_Set_Incr
1507         (S : in out Sink; F : Field_Enum; Get_Or_Set : String)
1508         with Pre => Get_Or_Set in "Get" | "Set";
1509       --  If statistics are enabled, put the appropriate increment statement
1510
1511       ----------------------
1512       -- Put_Get_Set_Incr --
1513       ----------------------
1514
1515       procedure Put_Get_Set_Incr
1516         (S : in out Sink; F : Field_Enum; Get_Or_Set : String) is
1517       begin
1518          if Statistics_Enabled then
1519             Put (S, "Atree." & Get_Or_Set & "_Count (" & F_Image (F) &
1520                    ") := Atree." & Get_Or_Set & "_Count (" &
1521                    F_Image (F) & ") + 1;" & LF);
1522          end if;
1523       end Put_Get_Set_Incr;
1524
1525       ------------------------
1526       -- Node_To_Fetch_From --
1527       ------------------------
1528
1529       function Node_To_Fetch_From (F : Field_Enum) return String is
1530       begin
1531          return
1532            (case Field_Table (F).Type_Only is
1533               when No_Type_Only => "N",
1534               when Base_Type_Only => "Base_Type (N)",
1535               when Impl_Base_Type_Only => "Implementation_Base_Type (N)",
1536               when Root_Type_Only => "Root_Type (N)");
1537       end Node_To_Fetch_From;
1538
1539       ---------------------
1540       -- Put_Getter_Spec --
1541       ---------------------
1542
1543       procedure Put_Getter_Spec (S : in out Sink; F : Field_Enum) is
1544       begin
1545          Put (S, "function " & Image (F));
1546          Put (S, " (N : " & N_Type (F) & ") return " &
1547               Get_Set_Id_Image (Field_Table (F).Field_Type));
1548       end Put_Getter_Spec;
1549
1550       ---------------------
1551       -- Put_Getter_Decl --
1552       ---------------------
1553
1554       procedure Put_Getter_Decl (S : in out Sink; F : Field_Enum) is
1555       begin
1556          Put_Getter_Spec (S, F);
1557          Put (S, " with " & Inline);
1558          Increase_Indent (S, 2);
1559          Put_Precondition (S, F);
1560          Decrease_Indent (S, 2);
1561          Put (S, ";" & LF);
1562       end Put_Getter_Decl;
1563
1564       ------------------------------
1565       -- Put_Getter_Setter_Locals --
1566       ------------------------------
1567
1568       procedure Put_Getter_Setter_Locals
1569         (S : in out Sink; F : Field_Enum; Get : Boolean)
1570       is
1571          Rec : Field_Info renames Field_Table (F).all;
1572
1573          F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type);
1574          Off : constant Field_Offset := Rec.Offset;
1575          F_Per_Slot : constant Field_Offset :=
1576            SS / Field_Offset (Field_Size (Rec.Field_Type));
1577          Slot_Off : constant Field_Offset := Off / F_Per_Slot;
1578          In_NH : constant Boolean := Slot_Off < Num_Header_Slots;
1579
1580          N : constant String :=
1581            (if Get then Node_To_Fetch_From (F) else "N");
1582
1583       begin
1584          Put (S, " is" & LF);
1585          Increase_Indent (S, 3);
1586          Put (S, "--  " & Image (F_Per_Slot) & "  " & Image (F_Size) &
1587                 "-bit fields per " & SSS & "-bit slot." & LF);
1588          Put (S, "--  Offset " & Image (Off) & " = " &
1589                 Image (Slot_Off) & " slots + " & Image (Off mod F_Per_Slot) &
1590                 " fields in slot." & LF & LF);
1591
1592          Put (S, "Off : constant := " & Image (Off) & ";" & LF);
1593          Put (S, "F_Size : constant := " & Image (F_Size) & ";" & LF);
1594
1595          if Field_Size (Rec.Field_Type) /= SS then
1596             Put (S, "Mask : constant := 2**F_Size - 1;" & LF);
1597          end if;
1598
1599          Put (S, "F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;" & LF);
1600          Put (S, "Slot_Off : constant Field_Offset := Off / F_Per_Slot;" & LF);
1601
1602          if In_NH then
1603             Put (S, "S : Slot renames Node_Offsets.Table (" & N & ").Slots (Slot_Off);" & LF);
1604          else
1605             Put (S, "S : Slot renames Slots.Table (Node_Offsets.Table (" & N & ").Offset + Slot_Off);" & LF);
1606          end if;
1607
1608          if Field_Size (Rec.Field_Type) /= SS then
1609             Put (S, "V : constant Natural := Natural ((Off mod F_Per_Slot) * F_Size);" & LF);
1610             Put (S, LF);
1611          end if;
1612       end Put_Getter_Setter_Locals;
1613
1614       ---------------------
1615       -- Put_Getter_Body --
1616       ---------------------
1617
1618       procedure Put_Getter_Body (S : in out Sink; F : Field_Enum) is
1619          Rec : Field_Info renames Field_Table (F).all;
1620          F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type);
1621          T : constant String := Get_Set_Id_Image (Rec.Field_Type);
1622       begin
1623          --  Note that we store the result in a local constant below, so that
1624          --  the "Pre => ..." can refer to it. The constant is called Val so
1625          --  that it has the same name as the formal of the setter, so the
1626          --  "Pre => ..." can refer to it by the same name in both getter
1627          --  and setter.
1628
1629          Put_Getter_Spec (S, F);
1630          Put_Getter_Setter_Locals (S, F, Get => True);
1631
1632          Put (S, "Raw : constant Field_Size_" & Image (F_Size) & "_Bit :=" & LF);
1633          Increase_Indent (S, 2);
1634          Put (S, "Field_Size_" & Image (F_Size) & "_Bit (");
1635
1636          if Field_Size (Rec.Field_Type) /= SS then
1637             Put (S, "Shift_Right (S, V) and Mask);" & LF);
1638          else
1639             Put (S, "S);" & LF);
1640          end if;
1641
1642          Decrease_Indent (S, 2);
1643
1644          Put (S, "Val : constant " & T & " :=");
1645
1646          if Field_Has_Special_Default (Rec.Field_Type) then
1647             pragma Assert (Field_Size (Rec.Field_Type) = 32);
1648             Put (S, LF);
1649             Increase_Indent (S, 2);
1650             Put (S, "(if Raw = 0 then " & Special_Default (Rec.Field_Type) &
1651                    " else " & "Cast (Raw));");
1652             Decrease_Indent (S, 2);
1653
1654          else
1655             Put (S, " Cast (Raw);");
1656          end if;
1657
1658          Put (S, LF);
1659
1660          Decrease_Indent (S, 3);
1661          Put (S, "begin" & LF);
1662          Increase_Indent (S, 3);
1663
1664          Put (S, "--  pragma Debug (Validate_Node_And_Offset (NN, Slot_Off));" & LF);
1665          --  Comment out the validation, because it's too slow, and because the
1666          --  relevant routines in Atree are not visible.
1667
1668          if Rec.Pre.all /= "" then
1669             Put (S, "pragma Assert (" & Rec.Pre.all & ");" & LF);
1670          end if;
1671
1672          if Rec.Pre_Get.all /= "" then
1673             Put (S, "pragma Assert (" & Rec.Pre_Get.all & ");" & LF);
1674          end if;
1675
1676          Put_Get_Set_Incr (S, F, "Get");
1677          Put (S, "return Val;" & LF);
1678          Decrease_Indent (S, 3);
1679          Put (S, "end " & Image (F) & ";" & LF & LF);
1680       end Put_Getter_Body;
1681
1682       ---------------------
1683       -- Put_Setter_Spec --
1684       ---------------------
1685
1686       procedure Put_Setter_Spec (S : in out Sink; F : Field_Enum) is
1687          Rec    : Field_Info renames Field_Table (F).all;
1688          Default : constant String :=
1689            (if Rec.Field_Type = Flag then " := True" else "");
1690       begin
1691          Put (S, "procedure Set_" & Image (F));
1692          Put (S, " (N : " & N_Type (F) & "; Val : " &
1693               Get_Set_Id_Image (Rec.Field_Type) & Default & ")");
1694       end Put_Setter_Spec;
1695
1696       ---------------------
1697       -- Put_Setter_Decl --
1698       ---------------------
1699
1700       procedure Put_Setter_Decl (S : in out Sink; F : Field_Enum) is
1701       begin
1702          Put_Setter_Spec (S, F);
1703          Put (S, " with " & Inline);
1704          Increase_Indent (S, 2);
1705          Put_Precondition (S, F);
1706          Decrease_Indent (S, 2);
1707          Put (S, ";" & LF);
1708       end Put_Setter_Decl;
1709
1710       ---------------------
1711       -- Put_Setter_Body --
1712       ---------------------
1713
1714       procedure Put_Setter_Body (S : in out Sink; F : Field_Enum) is
1715          Rec : Field_Info renames Field_Table (F).all;
1716          F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type);
1717
1718          --  If Type_Only was specified in the call to Create_Semantic_Field,
1719          --  then we assert that the node is a base type. We cannot assert that
1720          --  it is an implementation base type or a root type.
1721
1722          Type_Only_Assertion : constant String :=
1723            (case Rec.Type_Only is
1724               when No_Type_Only => "",
1725               when Base_Type_Only | Impl_Base_Type_Only | Root_Type_Only =>
1726                 "Is_Base_Type (N)");
1727       begin
1728          Put_Setter_Spec (S, F);
1729          Put_Getter_Setter_Locals (S, F, Get => False);
1730
1731          Put (S, "Raw : constant Field_Size_" & Image (F_Size) & "_Bit := Cast (Val);" & LF);
1732
1733          Decrease_Indent (S, 3);
1734          Put (S, "begin" & LF);
1735          Increase_Indent (S, 3);
1736
1737          Put (S, "--  pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off));" & LF);
1738          --  Comment out the validation, because it's too slow, and because the
1739          --  relevant routines in Atree are not visible.
1740
1741          if Rec.Pre.all /= "" then
1742             Put (S, "pragma Assert (" & Rec.Pre.all & ");" & LF);
1743          end if;
1744
1745          if Rec.Pre_Set.all /= "" then
1746             Put (S, "pragma Assert (" & Rec.Pre_Set.all & ");" & LF);
1747          end if;
1748
1749          if Type_Only_Assertion /= "" then
1750             Put (S, "pragma Assert (" & Type_Only_Assertion & ");" & LF);
1751          end if;
1752
1753          if Setter_Needs_Parent (F) then
1754             declare
1755                Err : constant String :=
1756                  (if Rec.Field_Type = List_Id then "Error_List" else "Error");
1757             begin
1758                Put (S, "if Present (Val) and then Val /= " & Err & " then" & LF);
1759                Increase_Indent (S, 3);
1760                Put (S, "pragma Warnings (Off, ""actuals for this call may be in wrong order"");" & LF);
1761                Put (S, "Set_Parent (Val, N);" & LF);
1762                Put (S, "pragma Warnings (On, ""actuals for this call may be in wrong order"");" & LF);
1763                Decrease_Indent (S, 3);
1764                Put (S, "end if;" & LF & LF);
1765             end;
1766          end if;
1767
1768          if Field_Size (Rec.Field_Type) /= SS then
1769             Put (S, "S := (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Raw), V);" & LF);
1770
1771          else
1772             Put (S, "S := Slot (Raw);" & LF);
1773          end if;
1774
1775          Put_Get_Set_Incr (S, F, "Set");
1776
1777          Decrease_Indent (S, 3);
1778          Put (S, "end Set_" & Image (F) & ";" & LF & LF);
1779       end Put_Setter_Body;
1780
1781       --------------------
1782       -- Put_Subp_Decls --
1783       --------------------
1784
1785       procedure Put_Subp_Decls (S : in out Sink; Root : Root_Type) is
1786          --  Note that there are several fields that are defined for both nodes
1787          --  and entities, such as Nkind. These are allocated slots in both,
1788          --  but here we only put out getters and setters in Sinfo.Nodes, not
1789          --  Einfo.Entities.
1790
1791       begin
1792          Put (S, "--  Getters and setters for fields" & LF);
1793
1794          for F in First_Field (Root) .. Last_Field (Root) loop
1795             --  Nkind/Ekind getter is already done (see Put_Type_And_Subtypes),
1796             --  and there is no setter for these.
1797
1798             if F = Nkind then
1799                Put (S, LF & "--  Nkind getter is above" & LF);
1800
1801             elsif F = Ekind then
1802                Put (S, LF & "--  Ekind getter is above" & LF);
1803
1804             else
1805                Put_Getter_Decl (S, F);
1806                Put_Setter_Decl (S, F);
1807             end if;
1808
1809             Put (S, LF);
1810          end loop;
1811       end Put_Subp_Decls;
1812
1813       ---------------------
1814       -- Put_Subp_Bodies --
1815       ---------------------
1816
1817       procedure Put_Subp_Bodies (S : in out Sink; Root : Root_Type) is
1818       begin
1819          Put (S, LF & "--  Getters and setters for fields" & LF & LF);
1820
1821          for F in First_Field (Root) .. Last_Field (Root) loop
1822             Put_Getter_Body (S, F);
1823
1824             if F not in Nkind | Ekind then
1825                Put_Setter_Body (S, F);
1826             end if;
1827          end loop;
1828       end Put_Subp_Bodies;
1829
1830       --------------------------
1831       -- Put_Traversed_Fields --
1832       --------------------------
1833
1834       procedure Put_Traversed_Fields (S : in out Sink) is
1835
1836          function Is_Traversed_Field
1837            (T : Concrete_Node; F : Field_Enum) return Boolean;
1838          --  True if F is a field that should be traversed by Traverse_Func. In
1839          --  particular, True if F is a syntactic field of T, and is of a
1840          --  Node_Id or List_Id type.
1841
1842          function Init_Max_Traversed_Fields return Field_Offset;
1843          --  Compute the maximum number of syntactic fields that are of type
1844          --  Node_Id or List_Id over all node types.
1845
1846          procedure Put_Aggregate (T : Node_Or_Entity_Type);
1847          --  Print out the subaggregate for one type
1848
1849          function Is_Traversed_Field
1850            (T : Concrete_Node; F : Field_Enum) return Boolean is
1851          begin
1852             return Syntactic (T) (F)
1853               and then Field_Table (F).Field_Type in Traversed_Field_Type;
1854          end Is_Traversed_Field;
1855
1856          First_Time : Boolean := True;
1857
1858          procedure Put_Aggregate (T : Node_Or_Entity_Type) is
1859             Left_Opnd_Skipped : Boolean := False;
1860          begin
1861             if T in Concrete_Node then
1862                if First_Time then
1863                   First_Time := False;
1864                else
1865                   Put (S, "," & LF);
1866                end if;
1867
1868                Put (S, Image (T) & " => (");
1869                Increase_Indent (S, 2);
1870
1871                for FI in 1 .. Last_Index (Type_Table (T).Fields) loop
1872                   declare
1873                      F : constant Field_Enum := Type_Table (T).Fields (FI);
1874
1875                   begin
1876                      if Is_Traversed_Field (T, F) then
1877                         if F = Left_Opnd then
1878                            Left_Opnd_Skipped := True; -- see comment below
1879
1880                         else
1881                            Put (S, Image (Field_Table (F).Offset) & ", ");
1882                         end if;
1883                      end if;
1884                   end;
1885                end loop;
1886
1887                --  We always put the Left_Opnd field of N_Op_Concat last. See
1888                --  comments in Atree.Traverse_Func for the reason. We might as
1889                --  well do that for all Left_Opnd fields; the old version did
1890                --  that.
1891
1892                if Left_Opnd_Skipped then
1893                   Put (S, Image (Field_Table (Left_Opnd).Offset) & ", ");
1894                end if;
1895
1896                Put (S, "others => No_Field_Offset");
1897
1898                Decrease_Indent (S, 2);
1899                Put (S, ")");
1900             end if;
1901          end Put_Aggregate;
1902
1903          function Init_Max_Traversed_Fields return Field_Offset is
1904             Result : Field_Offset := 0;
1905          begin
1906             for T in Concrete_Node loop
1907                declare
1908                   Num_Traversed_Fields : Field_Offset := 0; -- in type T
1909
1910                begin
1911                   for FI in 1 .. Last_Index (Type_Table (T).Fields) loop
1912                      declare
1913                         F : constant Field_Enum := Type_Table (T).Fields (FI);
1914
1915                      begin
1916                         if Is_Traversed_Field (T, F) then
1917                            Num_Traversed_Fields := Num_Traversed_Fields + 1;
1918                         end if;
1919                      end;
1920                   end loop;
1921
1922                   if Num_Traversed_Fields > Result then
1923                      Result := Num_Traversed_Fields;
1924                   end if;
1925                end;
1926             end loop;
1927
1928             return Result;
1929          end Init_Max_Traversed_Fields;
1930
1931          Max_Traversed_Fields : constant Field_Offset :=
1932            Init_Max_Traversed_Fields;
1933
1934       begin
1935          Put (S, "--  Table of fields that should be traversed by Traverse subprograms." & LF);
1936          Put (S, "--  Each entry is an array of offsets in slots of fields to be" & LF);
1937          Put (S, "--  traversed, terminated by a sentinel equal to No_Field_Offset." & LF & LF);
1938
1939          Put (S, "subtype Traversed_Offset_Array is Offset_Array (0 .. " &
1940               Image (Max_Traversed_Fields - 1) & " + 1);" & LF);
1941          Put (S, "Traversed_Fields : constant array (Node_Kind) of Traversed_Offset_Array :=" & LF);
1942          --  One extra for the sentinel
1943
1944          Increase_Indent (S, 2);
1945          Put (S, "(");
1946          Increase_Indent (S, 1);
1947          Iterate_Types (Node_Kind, Pre => Put_Aggregate'Access);
1948          Decrease_Indent (S, 1);
1949          Put (S, ");" & LF & LF);
1950          Decrease_Indent (S, 2);
1951       end Put_Traversed_Fields;
1952
1953       ----------------
1954       -- Put_Tables --
1955       ----------------
1956
1957       procedure Put_Tables (S : in out Sink; Root : Root_Type) is
1958
1959          First_Time : Boolean := True;
1960
1961          procedure Put_Size (T : Node_Or_Entity_Type);
1962          procedure Put_Size (T : Node_Or_Entity_Type) is
1963          begin
1964             if T in Concrete_Type then
1965                if First_Time then
1966                   First_Time := False;
1967                else
1968                   Put (S, "," & LF);
1969                end if;
1970
1971                Put (S, Image (T) & " => " & Image (Type_Size_In_Slots (T)));
1972             end if;
1973          end Put_Size;
1974
1975          procedure Put_Field_Array (T : Concrete_Type);
1976
1977          procedure Put_Field_Array (T : Concrete_Type) is
1978             First_Time : Boolean := True;
1979          begin
1980             for F in First_Field (Root) .. Last_Field (Root) loop
1981                if Fields_Per_Node (T) (F) then
1982                   if First_Time then
1983                      First_Time := False;
1984                   else
1985                      Put (S, "," & LF);
1986                   end if;
1987
1988                   Put (S, F_Image (F));
1989                end if;
1990             end loop;
1991          end Put_Field_Array;
1992
1993          Field_Enum_Type_Name : constant String :=
1994            (case Root is
1995               when Node_Kind => "Node_Field",
1996               when others => "Entity_Field");  -- Entity_Kind
1997
1998       begin
1999          Put (S, "--  Table of sizes in " & SSS & "-bit slots for given " &
2000               Image (Root) & ", for use by Atree:" & LF);
2001
2002          case Root is
2003             when Node_Kind =>
2004                Put (S, LF & "Min_Node_Size : constant Field_Offset := " &
2005                     Image (Min_Node_Size) & ";" & LF);
2006                Put (S, "Max_Node_Size : constant Field_Offset := " &
2007                     Image (Max_Node_Size) & ";" & LF & LF);
2008
2009             when Entity_Kind =>
2010                Put (S, LF & "Min_Entity_Size : constant Field_Offset := " &
2011                     Image (Min_Entity_Size) & ";" & LF);
2012                Put (S, "Max_Entity_Size : constant Field_Offset := " &
2013                     Image (Max_Entity_Size) & ";" & LF & LF);
2014             when others => raise Program_Error;
2015          end case;
2016
2017          Put (S, "Size : constant array (" & Image (Root) &
2018               ") of Field_Offset :=" & LF);
2019          Increase_Indent (S, 2);
2020          Put (S, "(");
2021          Increase_Indent (S, 1);
2022
2023          Iterate_Types (Root, Pre => Put_Size'Access);
2024
2025          Decrease_Indent (S, 1);
2026          Put (S, "); -- Size" & LF);
2027          Decrease_Indent (S, 2);
2028
2029          if Root = Node_Kind then
2030             declare
2031                type Node_Dummy is array (Node_Field) of Boolean;
2032                type Entity_Dummy is array (Entity_Field) of Boolean;
2033                Num_Fields : constant Root_Int :=
2034                  Node_Dummy'Length + Entity_Dummy'Length;
2035                First_Time : Boolean := True;
2036             begin
2037                Put (S, LF & "--  Enumeration of all " & Image (Num_Fields)
2038                     & " fields:" & LF & LF);
2039
2040                Put (S, "type Node_Or_Entity_Field is" & LF);
2041                Increase_Indent (S, 2);
2042                Put (S, "(");
2043                Increase_Indent (S, 1);
2044
2045                for F in Node_Field loop
2046                   if First_Time then
2047                      First_Time := False;
2048                   else
2049                      Put (S, "," & LF);
2050                   end if;
2051
2052                   Put (S, F_Image (F));
2053                end loop;
2054
2055                for F in Entity_Field loop
2056                   Put (S, "," & LF);
2057                   Put (S, F_Image (F));
2058                end loop;
2059
2060                Decrease_Indent (S, 1);
2061                Put (S, "); -- Node_Or_Entity_Field" & LF);
2062                Decrease_Indent (S, 2);
2063             end;
2064          end if;
2065
2066          Put (S, LF & "subtype " & Field_Enum_Type_Name & " is" & LF);
2067          Increase_Indent (S, 2);
2068          Put (S, "Node_Or_Entity_Field range " & F_Image (First_Field (Root)) &
2069                 " .. " & F_Image (Last_Field (Root)) & ";" & LF);
2070          Decrease_Indent (S, 2);
2071
2072          Put (S, LF & "type " & Field_Enum_Type_Name & "_Index is new Pos;" & LF);
2073          Put (S, "type " & Field_Enum_Type_Name & "_Array is array (" &
2074               Field_Enum_Type_Name & "_Index range <>) of " &
2075               Field_Enum_Type_Name & ";" & LF);
2076          Put (S, "type " & Field_Enum_Type_Name &
2077               "_Array_Ref is access constant " & Field_Enum_Type_Name &
2078               "_Array;" & LF);
2079          Put (S, "subtype A is " & Field_Enum_Type_Name & "_Array;" & LF);
2080          --  Short name to make allocators below more readable
2081
2082          declare
2083             First_Time : Boolean := True;
2084
2085             procedure Do_One_Type (T : Node_Or_Entity_Type);
2086             procedure Do_One_Type (T : Node_Or_Entity_Type) is
2087             begin
2088                if T in Concrete_Type then
2089                   if First_Time then
2090                      First_Time := False;
2091                   else
2092                      Put (S, "," & LF);
2093                   end if;
2094
2095                   Put (S, Image (T) & " =>" & LF);
2096                   Increase_Indent (S, 2);
2097                   Put (S, "new A'(");
2098                   Increase_Indent (S, 6);
2099                   Increase_Indent (S, 1);
2100
2101                   Put_Field_Array (T);
2102
2103                   Decrease_Indent (S, 1);
2104                   Put (S, ")");
2105                   Decrease_Indent (S, 6);
2106                   Decrease_Indent (S, 2);
2107                end if;
2108             end Do_One_Type;
2109          begin
2110             Put (S, LF & "--  Table mapping " & Image (Root) &
2111                  "s to the sequence of fields that exist in that " &
2112                  Image (Root) & ":" & LF & LF);
2113
2114             Put (S, Field_Enum_Type_Name & "_Table : constant array (" &
2115                  Image (Root) & ") of " & Field_Enum_Type_Name &
2116                  "_Array_Ref :=" & LF);
2117
2118             Increase_Indent (S, 2);
2119             Put (S, "(");
2120             Increase_Indent (S, 1);
2121
2122             Iterate_Types (Root, Pre => Do_One_Type'Access);
2123
2124             Decrease_Indent (S, 1);
2125             Put (S, "); -- " & Field_Enum_Type_Name & "_Table" & LF);
2126             Decrease_Indent (S, 2);
2127          end;
2128
2129          if Root = Node_Kind then
2130             declare
2131                First_Time : Boolean := True;
2132                FS, FB, LB : Bit_Offset;
2133                --  Field size in bits, first bit, and last bit for the previous
2134                --  time around the loop. Used to print a comment after ",".
2135
2136                procedure One_Comp (F : Field_Enum);
2137
2138                --------------
2139                -- One_Comp --
2140                --------------
2141
2142                procedure One_Comp (F : Field_Enum) is
2143                   pragma Annotate (Codepeer, Modified, Field_Table);
2144                   Offset : constant Field_Offset := Field_Table (F).Offset;
2145                begin
2146                   if First_Time then
2147                      First_Time := False;
2148                   else
2149                      Put (S, ",");
2150
2151                      --  Print comment showing field's bits, except for 1-bit
2152                      --  fields.
2153
2154                      if FS /= 1 then
2155                         Put (S, " -- *" & Image (FS) & " = bits " &
2156                                Image (FB) & ".." & Image (LB));
2157                      end if;
2158
2159                      Put (S, LF);
2160                   end if;
2161
2162                   Put (S, F_Image (F) & " => (" &
2163                        Image (Field_Table (F).Field_Type) & "_Field, " &
2164                        Image (Offset) & ", " &
2165                        Image (Field_Table (F).Type_Only) & ")");
2166
2167                   FS := Field_Size (F);
2168                   FB := First_Bit (F, Offset);
2169                   LB := Last_Bit (F, Offset);
2170                end One_Comp;
2171
2172             begin
2173                Put (S, LF & "--  Table mapping fields to kind and offset:" & LF & LF);
2174
2175                Put (S, "Field_Descriptors : constant array (" &
2176                     "Node_Or_Entity_Field) of Field_Descriptor :=" & LF);
2177
2178                Increase_Indent (S, 2);
2179                Put (S, "(");
2180                Increase_Indent (S, 1);
2181
2182                for F in Node_Field loop
2183                   One_Comp (F);
2184                end loop;
2185
2186                for F in Entity_Field loop
2187                   One_Comp (F);
2188                end loop;
2189
2190                Decrease_Indent (S, 1);
2191                Put (S, "); -- Field_Descriptors" & LF);
2192                Decrease_Indent (S, 2);
2193             end;
2194          end if;
2195
2196       end Put_Tables;
2197
2198       ----------------
2199       -- Put_Seinfo --
2200       ----------------
2201
2202       procedure Put_Seinfo is
2203          S : Sink;
2204       begin
2205          Create_File (S, "seinfo.ads");
2206          Put (S, "with Types; use Types;" & LF);
2207          Put (S, LF & "package Seinfo is" & LF & LF);
2208          Increase_Indent (S, 3);
2209
2210          Put (S, "--  This package is automatically generated." & LF & LF);
2211
2212          Put (S, "--  Common declarations visible in both Sinfo.Nodes and Einfo.Entities." & LF);
2213
2214          Put (S, LF & "type Field_Kind is" & LF);
2215          Increase_Indent (S, 2);
2216          Put (S, "(");
2217          Increase_Indent (S, 1);
2218
2219          declare
2220             First_Time : Boolean := True;
2221          begin
2222             for T in Special_Type loop
2223                if First_Time then
2224                   First_Time := False;
2225                else
2226                   Put (S, "," & LF);
2227                end if;
2228
2229                Put (S, Image (T) & "_Field");
2230             end loop;
2231          end;
2232
2233          Decrease_Indent (S, 1);
2234          Decrease_Indent (S, 2);
2235          Put (S, ");" & LF);
2236
2237          Put (S, LF & "Field_Size : constant array (Field_Kind) of Field_Size_In_Bits :=" & LF);
2238          Increase_Indent (S, 2);
2239          Put (S, "(");
2240          Increase_Indent (S, 1);
2241
2242          declare
2243             First_Time : Boolean := True;
2244          begin
2245             for T in Special_Type loop
2246                if First_Time then
2247                   First_Time := False;
2248                else
2249                   Put (S, "," & LF);
2250                end if;
2251
2252                Put (S, Image (T) & "_Field => " & Image (Field_Size (T)));
2253             end loop;
2254          end;
2255
2256          Decrease_Indent (S, 1);
2257          Decrease_Indent (S, 2);
2258          Put (S, ");" & LF & LF);
2259
2260          Put (S, "type Type_Only_Enum is" & LF);
2261          Increase_Indent (S, 2);
2262          Put (S, "(");
2263
2264          declare
2265             First_Time : Boolean := True;
2266          begin
2267             for TO in Type_Only_Enum loop
2268                if First_Time then
2269                   First_Time := False;
2270                else
2271                   Put (S, ", ");
2272                end if;
2273
2274                Put (S, Image (TO));
2275             end loop;
2276          end;
2277
2278          Decrease_Indent (S, 2);
2279          Put (S, ");" & LF & LF);
2280
2281          Put (S, "type Field_Descriptor is record" & LF);
2282          Increase_Indent (S, 3);
2283          Put (S, "Kind : Field_Kind;" & LF);
2284          Put (S, "Offset : Field_Offset;" & LF);
2285          Put (S, "Type_Only : Type_Only_Enum;" & LF);
2286          Decrease_Indent (S, 3);
2287          Put (S, "end record;" & LF & LF);
2288
2289          --  Print out the node header types. Note that the Offset field is of
2290          --  the base type, because we are using zero-origin addressing in
2291          --  Atree.
2292
2293          Put (S, "N_Head : constant Field_Offset := " & N_Head & ";" & LF & LF);
2294
2295          Put (S, "Atree_Statistics_Enabled : constant Boolean := " &
2296                 Capitalize (Boolean'Image (Statistics_Enabled)) & ";" & LF);
2297
2298          Decrease_Indent (S, 3);
2299          Put (S, LF & "end Seinfo;" & LF);
2300       end Put_Seinfo;
2301
2302       ---------------
2303       -- Put_Nodes --
2304       ---------------
2305
2306       procedure Put_Nodes is
2307          S : Sink;
2308          B : Sink;
2309
2310       begin
2311          Create_File (S, "sinfo-nodes.ads");
2312          Create_File (B, "sinfo-nodes.adb");
2313          Put (S, "with Seinfo; use Seinfo;" & LF);
2314          Put (S, "pragma Warnings (Off);" & LF);
2315          --  With's included in case they are needed; so we don't have to keep
2316          --  switching back and forth.
2317          Put (S, "with Output; use Output;" & LF);
2318          Put (S, "pragma Warnings (On);" & LF);
2319
2320          Put (S, LF & "package Sinfo.Nodes is" & LF & LF);
2321          Increase_Indent (S, 3);
2322
2323          Put (S, "--  This package is automatically generated." & LF & LF);
2324
2325          Put_Type_Hierarchy (S, Node_Kind);
2326
2327          Put_Type_And_Subtypes (S, Node_Kind);
2328
2329          Put (S, "pragma Assert (Node_Kind'Pos (N_Unused_At_Start) = 0);" & LF & LF);
2330          Put (S, "pragma Assert (Node_Kind'Last = N_Unused_At_End);" & LF & LF);
2331
2332          Put_Subp_Decls (S, Node_Kind);
2333
2334          Put_Traversed_Fields (S);
2335
2336          Put_Tables (S, Node_Kind);
2337
2338          Decrease_Indent (S, 3);
2339          Put (S, LF & "end Sinfo.Nodes;" & LF);
2340
2341          Put (B, "with Ada.Unchecked_Conversion;" & LF);
2342          Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;" & LF);
2343          Put (B, "with Nlists; use Nlists;" & LF);
2344          Put (B, "pragma Warnings (Off);" & LF);
2345          Put (B, "with Einfo.Utils; use Einfo.Utils;" & LF);
2346          Put (B, "with Sinfo.Utils; use Sinfo.Utils;" & LF);
2347          Put (B, "pragma Warnings (On);" & LF);
2348
2349          Put (B, LF & "package body Sinfo.Nodes is" & LF & LF);
2350          Increase_Indent (B, 3);
2351
2352          Put (B, "--  This package is automatically generated." & LF & LF);
2353
2354          Put (B, "pragma Style_Checks (""M200"");" & LF);
2355
2356          for T in Special_Type loop
2357             if Node_Field_Types_Used (T) then
2358                Put_Casts (B, T);
2359             end if;
2360          end loop;
2361
2362          Put_Subp_Bodies (B, Node_Kind);
2363
2364          Decrease_Indent (B, 3);
2365          Put (B, "end Sinfo.Nodes;" & LF);
2366
2367       end Put_Nodes;
2368
2369       ------------------
2370       -- Put_Entities --
2371       ------------------
2372
2373       procedure Put_Entities is
2374          S : Sink;
2375          B : Sink;
2376       begin
2377          Create_File (S, "einfo-entities.ads");
2378          Create_File (B, "einfo-entities.adb");
2379          Put (S, "with Sinfo.Nodes; use Sinfo.Nodes;" & LF);
2380
2381          Put (S, LF & "package Einfo.Entities is" & LF & LF);
2382          Increase_Indent (S, 3);
2383
2384          Put (S, "--  This package is automatically generated." & LF & LF);
2385
2386          Put_Type_Hierarchy (S, Entity_Kind);
2387
2388          Put_Type_And_Subtypes (S, Entity_Kind);
2389
2390          Put_Subp_Decls (S, Entity_Kind);
2391
2392          Put_Tables (S, Entity_Kind);
2393
2394          Decrease_Indent (S, 3);
2395          Put (S, LF & "end Einfo.Entities;" & LF);
2396
2397          Put (B, "with Ada.Unchecked_Conversion;" & LF);
2398          Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;" & LF);
2399          Put (B, "with Einfo.Utils; use Einfo.Utils;" & LF);
2400          --  This forms a cycle between packages (via bodies, which is OK)
2401
2402          Put (B, LF & "package body Einfo.Entities is" & LF & LF);
2403          Increase_Indent (B, 3);
2404
2405          Put (B, "--  This package is automatically generated." & LF & LF);
2406
2407          Put (B, "pragma Style_Checks (""M200"");" & LF);
2408
2409          for T in Special_Type loop
2410             if Entity_Field_Types_Used (T) then
2411                Put_Casts (B, T);
2412             end if;
2413          end loop;
2414
2415          Put_Subp_Bodies (B, Entity_Kind);
2416
2417          Decrease_Indent (B, 3);
2418          Put (B, "end Einfo.Entities;" & LF);
2419
2420       end Put_Entities;
2421
2422       -------------------
2423       -- Put_Make_Spec --
2424       -------------------
2425
2426       procedure Put_Make_Spec
2427         (S : in out Sink; Root : Root_Type; T : Concrete_Type)
2428       is
2429       begin
2430          Put (S, "function Make_" & Image_Sans_N (T) & "" & LF);
2431          Increase_Indent (S, 2);
2432          Put (S, "(Sloc : Source_Ptr");
2433          Increase_Indent (S, 1);
2434
2435          for F of Type_Table (T).Fields loop
2436             pragma Assert (Fields_Per_Node (T) (F));
2437
2438             if Syntactic (T) (F) then
2439                declare
2440                   Typ : constant String :=
2441                     (if Field_Table (F).Field_Type = Flag then "Boolean"
2442                      else Image (Field_Table (F).Field_Type));
2443
2444                   --  All Flag fields have a default, which is False by
2445                   --  default.
2446
2447                   Default : constant String :=
2448                     (if Field_Table (F).Default_Value = No_Default then
2449                      (if Field_Table (F).Field_Type = Flag then " := False" else "")
2450                      else " := " & Value_Image (Field_Table (F).Default_Value));
2451
2452                begin
2453                   Put (S, ";" & LF);
2454                   Put (S, Image (F));
2455                   Put (S, " : " & Typ & Default);
2456                end;
2457             end if;
2458          end loop;
2459
2460          Put (S, ")" & LF);
2461          Put (S, "return " & Node_Or_Entity (Root) & "_Id");
2462          Decrease_Indent (S, 2);
2463          Decrease_Indent (S, 1);
2464       end Put_Make_Spec;
2465
2466       --------------------
2467       -- Put_Make_Decls --
2468       --------------------
2469
2470       procedure Put_Make_Decls (S : in out Sink; Root : Root_Type) is
2471       begin
2472          for T in First_Concrete (Root) .. Last_Concrete (Root) loop
2473             if T not in N_Unused_At_Start | N_Unused_At_End then
2474                Put_Make_Spec (S, Root, T);
2475                Put (S, ";" & LF);
2476                Put (S, "pragma " & Inline & " (Make_" &
2477                     Image_Sans_N (T) & ");" & LF & LF);
2478             end if;
2479          end loop;
2480       end Put_Make_Decls;
2481
2482       ---------------------
2483       -- Put_Make_Bodies --
2484       ---------------------
2485
2486       procedure Put_Make_Bodies (S : in out Sink; Root : Root_Type) is
2487       begin
2488          for T in First_Concrete (Root) .. Last_Concrete (Root) loop
2489             if T not in N_Unused_At_Start | N_Unused_At_End then
2490                Put_Make_Spec (S, Root, T);
2491                Put (S, LF & "is" & LF);
2492
2493                Increase_Indent (S, 3);
2494                Put (S, "N : constant Node_Id :=" & LF);
2495
2496                if T in Entity_Node then
2497                   Put (S, "      New_Entity (" & Image (T) & ", Sloc);" & LF);
2498
2499                else
2500                   Put (S, "      New_Node (" & Image (T) & ", Sloc);" & LF);
2501                end if;
2502
2503                Decrease_Indent (S, 3);
2504
2505                Put (S, "begin" & LF);
2506
2507                Increase_Indent (S, 3);
2508                for F of Type_Table (T).Fields loop
2509                   pragma Assert (Fields_Per_Node (T) (F));
2510
2511                   if Syntactic (T) (F) then
2512                      declare
2513                         NWidth : constant := 28;
2514                         --  This constant comes from the old Xnmake, which wraps
2515                         --  the Set_... call if the field name is that long or
2516                         --  longer.
2517
2518                         F_Name : constant String := Image (F);
2519
2520                      begin
2521                         if F_Name'Length < NWidth then
2522                            Put (S, "Set_" & F_Name & " (N, " & F_Name & ");" & LF);
2523
2524                         --  Wrap the line
2525
2526                         else
2527                            Put (S, "Set_" & F_Name & "" & LF);
2528                            Increase_Indent (S, 2);
2529                            Put (S, "(N, " & F_Name & ");" & LF);
2530                            Decrease_Indent (S, 2);
2531                         end if;
2532                      end;
2533                   end if;
2534                end loop;
2535
2536                if Is_Descendant (N_Op, T) then
2537                   --  Special cases for N_Op nodes: fill in the Chars and Entity
2538                   --  fields even though they were not passed in.
2539
2540                   declare
2541                      Op : constant String := Image_Sans_N (T);
2542                      --  This will be something like "Op_And" or "Op_Add"
2543
2544                      Op_Name_With_Op : constant String :=
2545                        (if T = N_Op_Plus then "Op_Add"
2546                         elsif T = N_Op_Minus then "Op_Subtract"
2547                         else Op);
2548                      --  Special cases for unary operators that have the same name
2549                      --  as a binary operator; we use the binary operator name in
2550                      --  that case.
2551
2552                      Slid : constant String (1 .. Op_Name_With_Op'Length) :=
2553                        Op_Name_With_Op;
2554                      pragma Assert (Slid (1 .. 3) = "Op_");
2555
2556                      Op_Name : constant String :=
2557                        (if T in N_Op_Rotate_Left |
2558                           N_Op_Rotate_Right |
2559                           N_Op_Shift_Left |
2560                           N_Op_Shift_Right |
2561                           N_Op_Shift_Right_Arithmetic
2562                         then Slid (4 .. Slid'Last)
2563                         else Slid);
2564                      --  Special cases for shifts and rotates; the node kind has
2565                      --  "Op_", but the Name_Id constant does not.
2566
2567                   begin
2568                      Put (S, "Set_Chars (N, Name_" & Op_Name & ");" & LF);
2569                      Put (S, "Set_Entity (N, Standard_" & Op & ");" & LF);
2570                   end;
2571                end if;
2572
2573                if Type_Table (T).Nmake_Assert.all /= "" then
2574                   Put (S, "pragma Assert (" &
2575                            Type_Table (T).Nmake_Assert.all & ");" & LF);
2576                end if;
2577
2578                Put (S, "return N;" & LF);
2579                Decrease_Indent (S, 3);
2580
2581                Put (S, "end Make_" & Image_Sans_N (T) & ";" & LF & LF);
2582             end if;
2583          end loop;
2584       end Put_Make_Bodies;
2585
2586       ---------------
2587       -- Put_Nmake --
2588       ---------------
2589
2590       --  Documentation for the Nmake package, generated by Put_Nmake below.
2591
2592       --  The Nmake package contains a set of routines used to construct tree
2593       --  nodes using a functional style. There is one routine for each node
2594       --  type defined in Gen_IL.Gen.Gen_Nodes with the general interface:
2595
2596       --    function Make_xxx (Sloc : Source_Ptr,
2597       --                       Field_Name_1 : Field_Name_1_Type [:= default]
2598       --                       Field_Name_2 : Field_Name_2_Type [:= default]
2599       --                       ...)
2600       --    return Node_Id
2601
2602       --  Only syntactic fields are included.
2603
2604       --  Default values are provided as specified in Gen_Nodes, except that if
2605       --  no default is specified for a flag field, it has a default of False.
2606
2607       --  Warning: since calls to Make_xxx routines are normal function calls, the
2608       --  arguments can be evaluated in any order. This means that at most one such
2609       --  argument can have side effects (e.g. be a call to a parse routine).
2610
2611       procedure Put_Nmake is
2612          S : Sink;
2613          B : Sink;
2614
2615       begin
2616          Create_File (S, "nmake.ads");
2617          Create_File (B, "nmake.adb");
2618          Put (S, "with Namet;  use Namet;" & LF);
2619          Put (S, "with Nlists; use Nlists;" & LF);
2620          Put (S, "with Types;  use Types;" & LF);
2621          Put (S, "with Uintp;  use Uintp;" & LF);
2622          Put (S, "with Urealp; use Urealp;" & LF);
2623
2624          Put (S, LF & "package Nmake is" & LF & LF);
2625          Increase_Indent (S, 3);
2626
2627          Put (S, "--  This package is automatically generated." & LF & LF);
2628          Put (S, "--  See Put_Nmake in gen_il-gen.adb for documentation." & LF & LF);
2629
2630          Put_Make_Decls (S, Node_Kind);
2631
2632          Decrease_Indent (S, 3);
2633          Put (S, "end Nmake;" & LF);
2634
2635          Put (B, "with Atree;  use Atree;" & LF);
2636          Put (B, "with Sinfo.Nodes; use Sinfo.Nodes;" & LF);
2637          Put (B, "with Sinfo.Utils; use Sinfo.Utils;" & LF);
2638          Put (B, "with Snames; use Snames;" & LF);
2639          Put (B, "with Stand;  use Stand;" & LF);
2640
2641          Put (B, LF & "package body Nmake is" & LF & LF);
2642          Increase_Indent (B, 3);
2643
2644          Put (B, "--  This package is automatically generated." & LF & LF);
2645          Put (B, "pragma Style_Checks (""M200"");" & LF);
2646
2647          Put_Make_Bodies (B, Node_Kind);
2648
2649          Decrease_Indent (B, 3);
2650          Put (B, "end Nmake;" & LF);
2651       end Put_Nmake;
2652
2653       -----------------------
2654       -- Put_Seinfo_Tables --
2655       -----------------------
2656
2657       procedure Put_Seinfo_Tables is
2658          S : Sink;
2659          B : Sink;
2660
2661          Type_Layout : Concrete_Type_Layout_Array;
2662
2663          function Get_Last_Bit
2664            (T : Concrete_Type; F : Opt_Field_Enum; First_Bit : Bit_Offset)
2665             return Bit_Offset;
2666          function First_Bit_Image (First_Bit : Bit_Offset) return String;
2667          function Last_Bit_Image (Last_Bit : Bit_Offset) return String;
2668
2669          procedure Put_Field_List (Bit : Bit_Offset);
2670          --  Print out the list of fields that are allocated (in part, for
2671          --  fields bigger than one bit) at the given bit offset. This allows
2672          --  us to see which fields are overlaid with each other, which should
2673          --  only happen if the sets of types with those fields are disjoint.
2674
2675          function Get_Last_Bit
2676            (T : Concrete_Type; F : Opt_Field_Enum; First_Bit : Bit_Offset)
2677             return Bit_Offset is
2678          begin
2679             return Result : Bit_Offset do
2680                if F = No_Field then
2681                   --  We don't have a field size for No_Field, so just look at
2682                   --  the bits up to the next slot boundary.
2683
2684                   Result := First_Bit;
2685
2686                   while (Result + 1) mod SS /= 0
2687                     and then Type_Layout (T) (Result + 1) = No_Field
2688                   loop
2689                      Result := Result + 1;
2690                   end loop;
2691
2692                else
2693                   Result := First_Bit + Field_Size (F) - 1;
2694                end if;
2695             end return;
2696          end Get_Last_Bit;
2697
2698          function First_Bit_Image (First_Bit : Bit_Offset) return String is
2699             W : constant Bit_Offset := First_Bit / SS;
2700             B : constant Bit_Offset := First_Bit mod SS;
2701             pragma Assert (W * SS + B = First_Bit);
2702          begin
2703             return
2704               Image (W) & "*" & SSS & (if B = 0 then "" else " + " & Image (B));
2705          end First_Bit_Image;
2706
2707          function Last_Bit_Image (Last_Bit : Bit_Offset) return String is
2708             W : constant Bit_Offset := (Last_Bit + 1) / SS;
2709          begin
2710             if W * SS - 1 = Last_Bit then
2711                return Image (W) & "*" & SSS & " - 1";
2712             else
2713                return First_Bit_Image (Last_Bit);
2714             end if;
2715          end Last_Bit_Image;
2716
2717          function Image_Or_Waste (F : Opt_Field_Enum) return String is
2718            (if F = No_Field then "Wasted_Bits" else Image (F));
2719
2720          Num_Wasted_Bits : Bit_Offset'Base := 0;
2721
2722          Type_Layout_Size : Bit_Offset'Base := Type_Layout'Size;
2723          --  Total size of Type_Layout, including the Field_Arrays its
2724          --  components point to.
2725
2726          procedure Put_Field_List (Bit : Bit_Offset) is
2727             First_Time : Boolean := True;
2728          begin
2729             for F in Field_Enum loop
2730                if F /= Between_Node_And_Entity_Fields
2731                  and then Bit in First_Bit (F, Field_Table (F).Offset)
2732                                .. Last_Bit (F, Field_Table (F).Offset)
2733                then
2734                   if First_Time then
2735                      First_Time := False;
2736                   else
2737                      Put (B, "," & LF);
2738                   end if;
2739
2740                   Put (B, Image (F));
2741                end if;
2742             end loop;
2743          end Put_Field_List;
2744
2745       begin -- Put_Seinfo_Tables
2746          Create_File (S, "seinfo_tables.ads");
2747          Create_File (B, "seinfo_tables.adb");
2748
2749          for T in Concrete_Type loop
2750             Type_Layout (T) := new Field_Array'
2751               (0 .. Type_Bit_Size_Aligned (T) - 1 => No_Field);
2752             Type_Layout_Size := Type_Layout_Size + Type_Layout (T).all'Size;
2753
2754             for F in Field_Enum loop
2755                if Fields_Per_Node (T) (F) then
2756                   declare
2757                      Off : constant Field_Offset := Field_Table (F).Offset;
2758                      subtype Bit_Range is Bit_Offset
2759                        range First_Bit (F, Off) .. Last_Bit (F, Off);
2760                   begin
2761                      pragma Assert
2762                        (Type_Layout (T) (Bit_Range) = (Bit_Range => No_Field));
2763                      Type_Layout (T) (Bit_Range) := (others => F);
2764                   end;
2765                end if;
2766             end loop;
2767          end loop;
2768
2769          for T in Concrete_Type loop
2770             for B in 0 .. Type_Bit_Size_Aligned (T) - 1 loop
2771                if Type_Layout (T) (B) = No_Field then
2772                   Num_Wasted_Bits := Num_Wasted_Bits + 1;
2773                end if;
2774             end loop;
2775          end loop;
2776
2777          Put (S, LF & "package Seinfo_Tables is" & LF & LF);
2778          Increase_Indent (S, 3);
2779
2780          Put (S, "--  This package is automatically generated." & LF & LF);
2781
2782          Put (S, "--  This package is not used by the compiler." & LF);
2783          Put (S, "--  The body contains tables that are intended to be used by humans to" & LF);
2784          Put (S, "--  help understand the layout of various data structures." & LF);
2785          Put (S, "--  Search for ""--"" to find major sections of code." & LF & LF);
2786
2787          Put (S, "pragma Elaborate_Body;" & LF);
2788
2789          Decrease_Indent (S, 3);
2790          Put (S, LF & "end Seinfo_Tables;" & LF);
2791
2792          Put (B, "with Gen_IL.Types;  use Gen_IL.Types;" & LF);
2793          Put (B, "with Gen_IL.Fields; use Gen_IL.Fields;" & LF);
2794          Put (B, "with Gen_IL.Internals;  use Gen_IL.Internals;" & LF);
2795
2796          Put (B, LF & "package body Seinfo_Tables is" & LF & LF);
2797          Increase_Indent (B, 3);
2798
2799          Put (B, "--  This package is automatically generated." & LF & LF);
2800
2801          Put (B, "Num_Wasted_Bits : Bit_Offset'Base := " & Image (Num_Wasted_Bits) &
2802               " with Unreferenced;" & LF);
2803
2804          Put (B, LF & "Wasted_Bits : constant Opt_Field_Enum := No_Field;" & LF);
2805
2806          Put (B, LF & "--  Table showing the layout of each Node_Or_Entity_Type. For each" & LF);
2807          Put (B, "--  concrete type, we show the bits used by each field. Each field" & LF);
2808          Put (B, "--  uses the same bit range in all types. This table is not used by" & LF);
2809          Put (B, "--  the compiler; it is for information only." & LF & LF);
2810
2811          Put (B, "--  Wasted_Bits are unused bits between fields, and padding at the end" & LF);
2812          Put (B, "--  to round up to a multiple of the slot size." & LF);
2813
2814          Put (B, LF & "--  Type_Layout is " & Image (Type_Layout_Size / 8) & " bytes." & LF);
2815
2816          Put (B, LF & "pragma Style_Checks (Off);" & LF);
2817          Put (B, "Type_Layout : constant Concrete_Type_Layout_Array := " & LF);
2818          Increase_Indent (B, 2);
2819          Put (B, "--  Concrete node types:" & LF);
2820          Put (B, "(");
2821          Increase_Indent (B, 1);
2822
2823          declare
2824             First_Time : Boolean := True;
2825
2826          begin
2827             for T in Concrete_Type loop
2828                if First_Time then
2829                   First_Time := False;
2830                else
2831                   Put (B, "," & LF & LF);
2832                end if;
2833
2834                if T = Concrete_Entity'First then
2835                   Put (B, "--  Concrete entity types:" & LF & LF);
2836                end if;
2837
2838                Put (B, Image (T) & " => new Field_Array'" & LF);
2839
2840                Increase_Indent (B, 2);
2841                Put (B, "(");
2842                Increase_Indent (B, 1);
2843
2844                declare
2845                   First_Time : Boolean := True;
2846                   First_Bit : Bit_Offset := 0;
2847                   F : Opt_Field_Enum;
2848
2849                   function Node_Field_Of_Entity return String is
2850                      (if T in Entity_Type and then F in Node_Field then
2851                        " -- N" else "");
2852                   --  A comment to put out for fields of entities that are
2853                   --  shared with nodes, such as Chars.
2854
2855                begin
2856                   while First_Bit < Type_Bit_Size_Aligned (T) loop
2857                      if First_Time then
2858                         First_Time := False;
2859                      else
2860                         Put (B, "," & Node_Field_Of_Entity & LF);
2861                      end if;
2862
2863                      F := Type_Layout (T) (First_Bit);
2864
2865                      declare
2866                         Last_Bit : constant Bit_Offset :=
2867                           Get_Last_Bit (T, F, First_Bit);
2868                      begin
2869                         pragma Assert
2870                           (Type_Layout (T) (First_Bit .. Last_Bit) =
2871                                            (First_Bit .. Last_Bit => F));
2872
2873                         if Last_Bit = First_Bit then
2874                            Put (B, First_Bit_Image (First_Bit) & " => " &
2875                                 Image_Or_Waste (F));
2876                         else
2877                            pragma Assert
2878                              (if F /= No_Field then
2879                                First_Bit mod Field_Size (F) = 0);
2880                            Put (B, First_Bit_Image (First_Bit) & " .. " &
2881                                 Last_Bit_Image (Last_Bit) & " => " &
2882                                 Image_Or_Waste (F));
2883                         end if;
2884
2885                         First_Bit := Last_Bit + 1;
2886                      end;
2887                   end loop;
2888                end;
2889
2890                Decrease_Indent (B, 1);
2891                Put (B, ")");
2892                Decrease_Indent (B, 2);
2893             end loop;
2894          end;
2895
2896          Decrease_Indent (B, 1);
2897          Put (B, ") -- Type_Layout" & LF);
2898          Increase_Indent (B, 6);
2899          Put (B, "with Export, Convention => Ada;" & LF);
2900          Decrease_Indent (B, 6);
2901          Decrease_Indent (B, 2);
2902
2903          Put (B, LF & "--  Table mapping bit offsets to the set of fields at that offset" & LF & LF);
2904          Put (B, "Bit_Used : constant Offset_To_Fields_Mapping :=" & LF);
2905
2906          Increase_Indent (B, 2);
2907          Put (B, "(");
2908          Increase_Indent (B, 1);
2909
2910          declare
2911             First_Time : Boolean := True;
2912          begin
2913             for Bit in 0 .. Bit_Offset'Max
2914               (Max_Node_Bit_Size, Max_Entity_Bit_Size)
2915             loop
2916                if First_Time then
2917                   First_Time := False;
2918                else
2919                   Put (B, "," & LF & LF);
2920                end if;
2921
2922                Put (B, First_Bit_Image (Bit) & " => new Field_Array'" & LF);
2923
2924                --  Use [...] notation here, to get around annoying Ada
2925                --  limitations on empty and singleton aggregates. This code is
2926                --  not used in the compiler, so there are no bootstrap issues.
2927
2928                Increase_Indent (B, 2);
2929                Put (B, "[");
2930                Increase_Indent (B, 1);
2931
2932                Put_Field_List (Bit);
2933
2934                Decrease_Indent (B, 1);
2935                Put (B, "]");
2936                Decrease_Indent (B, 2);
2937             end loop;
2938          end;
2939
2940          Decrease_Indent (B, 1);
2941          Put (B, "); -- Bit_Used" & LF);
2942          Decrease_Indent (B, 2);
2943
2944          Decrease_Indent (B, 3);
2945          Put (B, LF & "end Seinfo_Tables;" & LF);
2946
2947       end Put_Seinfo_Tables;
2948
2949       -----------------------------
2950       -- Put_C_Type_And_Subtypes --
2951       -----------------------------
2952
2953       procedure Put_C_Type_And_Subtypes
2954         (S : in out Sink; Root : Root_Type) is
2955
2956          Cur_Pos : Root_Nat := 0;
2957          --  Current Node_Kind'Pos or Entity_Kind'Pos to be printed
2958
2959          procedure Put_Enum_Lit (T : Node_Or_Entity_Type);
2960          --  Print out the enumerator corresponding to the Ada enumeration literal
2961          --  for T in Node_Kind and Entity_Kind (i.e. concrete types).
2962          --  This looks like "Some_Kind = <pos>", where Some_Kind
2963          --  is the Node_Kind or Entity_Kind enumeration literal, and
2964          --  <pos> is Node_Kind'Pos or Entity_Kind'Pos of that literal.
2965
2966          procedure Put_Kind_Subtype (T : Node_Or_Entity_Type);
2967          --  Print out the SUBTYPE macro call corresponding to an abstract
2968          --  type.
2969
2970          procedure Put_Enum_Lit (T : Node_Or_Entity_Type) is
2971          begin
2972             if T in Concrete_Type then
2973                Put (S, "  " & Image (T) & " = " & Image (Cur_Pos) & "," & LF);
2974                Cur_Pos := Cur_Pos + 1;
2975             end if;
2976          end Put_Enum_Lit;
2977
2978          procedure Put_Kind_Subtype (T : Node_Or_Entity_Type) is
2979          begin
2980             if T in Abstract_Type and then Type_Table (T).Parent /= No_Type then
2981                Put (S, "SUBTYPE (" & Image (T) & ", " &
2982                     Image (Type_Table (T).Parent) & "," & LF);
2983                Increase_Indent (S, 3);
2984                Put (S, Image (Type_Table (T).First) & "," & LF);
2985                Put (S, Image (Type_Table (T).Last) & ")" & LF);
2986                Decrease_Indent (S, 3);
2987             end if;
2988          end Put_Kind_Subtype;
2989
2990       begin
2991          Put_Union_Membership (S, Root, Only_Prototypes => True);
2992
2993          Put (S, "enum " & Node_Or_Entity (Root) & "_Kind : unsigned int {" & LF);
2994          Iterate_Types (Root, Pre => Put_Enum_Lit'Access);
2995          Put (S, "};" & LF);
2996
2997          Put (S, "#define Number_" & Node_Or_Entity (Root) & "_Kinds " &
2998               Image (Cur_Pos) & "" & LF & LF);
2999
3000          Iterate_Types (Root, Pre => Put_Kind_Subtype'Access);
3001
3002          Put_Union_Membership (S, Root, Only_Prototypes => False);
3003       end Put_C_Type_And_Subtypes;
3004
3005       ------------------
3006       -- Put_C_Getter --
3007       ------------------
3008
3009       procedure Put_C_Getter
3010         (S : in out Sink; F : Field_Enum)
3011       is
3012          Rec : Field_Info renames Field_Table (F).all;
3013
3014          Off : constant Field_Offset := Rec.Offset;
3015          F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type);
3016          F_Per_Slot : constant Field_Offset :=
3017            SS / Field_Offset (Field_Size (Rec.Field_Type));
3018          Slot_Off : constant Field_Offset := Off / F_Per_Slot;
3019          In_NH : constant Boolean := Slot_Off < Num_Header_Slots;
3020
3021          N : constant String := Node_To_Fetch_From (F);
3022       begin
3023          Put (S, "INLINE " & Get_Set_Id_Image (Rec.Field_Type) &
3024               " " & Image (F) & " (Node_Id N)" & LF);
3025
3026          Put (S, "{" & LF);
3027          Increase_Indent (S, 3);
3028          Put (S, "const Field_Offset Off = " & Image (Rec.Offset) & ";" & LF);
3029          Put (S, "const Field_Offset F_Size = " & Image (F_Size) & ";" & LF);
3030
3031          if Field_Size (Rec.Field_Type) /= SS then
3032             Put (S, "const any_slot Mask = (1 << F_Size) - 1;" & LF);
3033          end if;
3034
3035          Put (S, "const Field_Offset F_Per_Slot = Slot_Size / F_Size;" & LF);
3036          Put (S, "const Field_Offset Slot_Off = Off / F_Per_Slot;" & LF);
3037          Put (S, LF);
3038          if In_NH then
3039             Put (S, "any_slot slot = Node_Offsets_Ptr[" & N & "].Slots[Slot_Off];" & LF);
3040          else
3041             Put (S, "any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[" & N &
3042                    "].Offset + Slot_Off);" & LF);
3043          end if;
3044
3045          if Field_Size (Rec.Field_Type) /= SS then
3046             Put (S, "unsigned int Raw = (slot >> (Off % F_Per_Slot) * F_Size) & Mask;" & LF);
3047          else
3048             Put (S, "unsigned int Raw = slot;" & LF);
3049          end if;
3050
3051          Put (S, Get_Set_Id_Image (Rec.Field_Type) & " val = (" &
3052                 Get_Set_Id_Image (Rec.Field_Type) & ") ");
3053
3054          if Field_Has_Special_Default (Rec.Field_Type) then
3055             Increase_Indent (S, 2);
3056             Put (S, "(Raw? Raw : " & Special_Default (Rec.Field_Type) & ")");
3057             Decrease_Indent (S, 2);
3058
3059          else
3060             Put (S, "Raw");
3061          end if;
3062
3063          Put (S, ";" & LF);
3064
3065          Put (S, "return val;" & LF);
3066          Decrease_Indent (S, 3);
3067          Put (S, "}" & LF & LF);
3068       end Put_C_Getter;
3069
3070       -------------------
3071       -- Put_C_Getters --
3072       -------------------
3073
3074       procedure Put_C_Getters
3075         (S : in out Sink; Root : Root_Type)
3076       is
3077       begin
3078          Put (S, "// Getters for fields" & LF & LF);
3079
3080          for F in First_Field (Root) .. Last_Field (Root) loop
3081             Put_C_Getter (S, F);
3082          end loop;
3083       end Put_C_Getters;
3084
3085       --------------------------
3086       -- Put_Union_Membership --
3087       --------------------------
3088
3089       procedure Put_Union_Membership
3090         (S : in out Sink; Root : Root_Type; Only_Prototypes : Boolean) is
3091
3092          procedure Put_Ors (T : Abstract_Type);
3093          --  Print the "or" (i.e. "||") of tests whether kind is in each child
3094          --  type.
3095
3096          procedure Put_Ors (T : Abstract_Type) is
3097             First_Time : Boolean := True;
3098          begin
3099             for Child of Type_Table (T).Children loop
3100                if First_Time then
3101                   First_Time := False;
3102                else
3103                   Put (S, " ||" & LF);
3104                end if;
3105
3106                --  Unions, other abstract types, and concrete types each have
3107                --  their own way of testing membership in the C++ code.
3108
3109                if Child in Abstract_Type then
3110                   if Type_Table (Child).Is_Union then
3111                      Put (S, "Is_In_" & Image (Child) & " (kind)");
3112
3113                   else
3114                      Put (S, "IN (kind, " & Image (Child) & ")");
3115                   end if;
3116
3117                else
3118                   Put (S, "kind == " & Image (Child));
3119                end if;
3120             end loop;
3121          end Put_Ors;
3122
3123       begin
3124          if not Only_Prototypes then
3125             Put (S, LF & "// Membership tests for union types" & LF & LF);
3126          end if;
3127
3128          for T in First_Abstract (Root) .. Last_Abstract (Root) loop
3129             if Type_Table (T) /= null and then Type_Table (T).Is_Union then
3130                Put (S, "INLINE Boolean" & LF);
3131                Put (S, "Is_In_" & Image (T) & " (" &
3132                     Node_Or_Entity (Root) & "_Kind kind)" &
3133                     (if Only_Prototypes then ";" else "") & LF);
3134
3135                if not Only_Prototypes then
3136                   Put (S, "{" & LF);
3137                   Increase_Indent (S, 3);
3138                   Put (S, "return" & LF);
3139                   Increase_Indent (S, 3);
3140                   Put_Ors (T);
3141                   Decrease_Indent (S, 3);
3142                   Decrease_Indent (S, 3);
3143                   Put (S, ";" & LF & "}" & LF);
3144                end if;
3145
3146                Put (S, "" & LF);
3147             end if;
3148          end loop;
3149       end Put_Union_Membership;
3150
3151       ---------------------
3152       -- Put_Sinfo_Dot_H --
3153       ---------------------
3154
3155       procedure Put_Sinfo_Dot_H is
3156          S : Sink;
3157
3158       begin
3159          Create_File (S, "sinfo.h");
3160          Put (S, "#ifdef __cplusplus" & LF);
3161          Put (S, "extern ""C"" {" & LF);
3162          Put (S, "#endif" & LF & LF);
3163
3164          Put (S, "typedef Boolean Flag;" & LF & LF);
3165
3166          Put (S, "#define N_Head " & N_Head & LF);
3167          Put (S, "" & LF);
3168          Put (S, "typedef struct Node_Header {" & LF);
3169          Increase_Indent (S, 2);
3170          Put (S, "any_slot Slots[N_Head];" & LF);
3171          Put (S, "Field_Offset Offset;" & LF);
3172          Decrease_Indent (S, 2);
3173          Put (S, "} Node_Header;" & LF & LF);
3174
3175          Put (S, "extern Node_Header *Node_Offsets_Ptr;" & LF);
3176          Put (S, "extern any_slot *Slots_Ptr;" & LF & LF);
3177
3178          Put_C_Type_And_Subtypes (S, Node_Kind);
3179
3180          Put (S, "// Getters corresponding to instantiations of Atree.Get_n_Bit_Field"
3181                  & LF & LF);
3182
3183          Put_C_Getters (S, Node_Kind);
3184
3185          Put (S, "#ifdef __cplusplus" & LF);
3186          Put (S, "}" & LF);
3187          Put (S, "#endif" & LF);
3188       end Put_Sinfo_Dot_H;
3189
3190       ---------------------
3191       -- Put_Einfo_Dot_H --
3192       ---------------------
3193
3194       procedure Put_Einfo_Dot_H is
3195          S : Sink;
3196
3197          procedure Put_Membership_Query_Spec (T : Node_Or_Entity_Type);
3198          procedure Put_Membership_Query_Defn (T : Node_Or_Entity_Type);
3199          --  Print out the Is_... function for T that calls the IN macro on the
3200          --  SUBTYPE.
3201
3202          procedure Put_Membership_Query_Spec (T : Node_Or_Entity_Type) is
3203             Im : constant String := Image (T);
3204             pragma Assert (Im (Im'Last - 4 .. Im'Last) = "_Kind");
3205             Im2 : constant String := Im (Im'First .. Im'Last - 5);
3206             Typ : constant String :=
3207               (if Is_Descendant (Type_Kind, T)
3208                  and then T /= Type_Kind
3209                then "_Type"
3210                else "");
3211          begin
3212             pragma Assert (not Type_Table (T).Is_Union);
3213
3214             Put (S, "INLINE B Is_" & Im2 & Typ & " (E Id)");
3215          end Put_Membership_Query_Spec;
3216
3217          procedure Put_Membership_Query_Defn (T : Node_Or_Entity_Type) is
3218          begin
3219             if T in Abstract_Type and T not in Root_Type then
3220                Put_Membership_Query_Spec (T);
3221                Put (S, "" & LF);
3222                Increase_Indent (S, 3);
3223                Put (S, "{ return IN (Ekind (Id), " & Image (T) & "); }" & LF);
3224                Decrease_Indent (S, 3);
3225             end if;
3226          end Put_Membership_Query_Defn;
3227
3228       begin
3229          Create_File (S, "einfo.h");
3230          Put (S, "#ifdef __cplusplus" & LF);
3231          Put (S, "extern ""C"" {" & LF);
3232          Put (S, "#endif" & LF & LF);
3233
3234          Put (S, "typedef Boolean Flag;" & LF & LF);
3235
3236          Put_C_Type_And_Subtypes (S, Entity_Kind);
3237
3238          Put_C_Getters (S, Entity_Kind);
3239
3240          Put (S, "// Abstract type queries" & LF & LF);
3241
3242          Iterate_Types (Entity_Kind, Pre => Put_Membership_Query_Defn'Access);
3243
3244          Put (S, LF & "#ifdef __cplusplus" & LF);
3245          Put (S, "}" & LF);
3246          Put (S, "#endif" & LF);
3247       end Put_Einfo_Dot_H;
3248
3249    begin -- Compile
3250
3251       Check_Completeness;
3252
3253       Compute_Ranges (Node_Kind);
3254       Compute_Ranges (Entity_Kind);
3255       Compute_Fields_Per_Node;
3256       Compute_Field_Offsets;
3257       Compute_Type_Sizes;
3258       Check_For_Syntactic_Field_Mismatch;
3259
3260       Verify_Type_Table;
3261
3262       Node_Field_Types_Used :=
3263         Field_Types_Used (Node_Field'First, Node_Field'Last);
3264       Entity_Field_Types_Used :=
3265         Field_Types_Used (Entity_Field'First, Entity_Field'Last);
3266
3267       Put_Seinfo;
3268
3269       Put_Nodes;
3270
3271       Put_Entities;
3272
3273       Put_Nmake;
3274
3275       Put_Seinfo_Tables;
3276
3277       Put_Sinfo_Dot_H;
3278       Put_Einfo_Dot_H;
3279
3280    end Compile;
3281
3282    --------
3283    -- Sy --
3284    --------
3285
3286    function Sy
3287      (Field      : Node_Field;
3288       Field_Type : Type_Enum;
3289       Default_Value : Field_Default_Value := No_Default;
3290       Pre, Pre_Get, Pre_Set : String := "") return Field_Sequence is
3291    begin
3292       return
3293         (1 => Create_Syntactic_Field
3294            (Field, Field_Type, Default_Value, Pre, Pre_Get, Pre_Set));
3295    end Sy;
3296
3297    --------
3298    -- Sm --
3299    --------
3300
3301    function Sm
3302      (Field      : Field_Enum;
3303       Field_Type : Type_Enum;
3304       Type_Only  : Type_Only_Enum := No_Type_Only;
3305       Pre, Pre_Get, Pre_Set : String := "") return Field_Sequence is
3306    begin
3307       return (1 => Create_Semantic_Field
3308                 (Field, Field_Type, Type_Only, Pre, Pre_Get, Pre_Set));
3309    end Sm;
3310
3311 end Gen_IL.Gen;