------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                            G E N _ I L . G E N                           --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 2020-2021, Free Software Foundation, Inc.         --
--                                                                          --
-- GNAT is free software;  you can  redistribute it  and/or modify it under --
-- terms of the  GNU General Public License as published  by the Free Soft- --
-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
-- for  more details.  You should have  received  a copy of the GNU General --
-- Public License  distributed with GNAT; see file COPYING3.  If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license.          --
--                                                                          --
-- GNAT was originally developed  by the GNAT team at  New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc.      --
--                                                                          --
------------------------------------------------------------------------------

with Ada.Containers; use type Ada.Containers.Count_Type;
with Ada.Text_IO;

package body Gen_IL.Gen is

   Statistics_Enabled : constant Boolean := False;
   --  Change to True or False to enable/disable statistics printed by
   --  Atree. Should normally be False, for efficiency. Also compile with
   --  -gnatd.A to get the statistics printed.  Enabling these statistics
   --  makes the compiler about 20% slower.

   Num_Header_Slots : constant := 3;
   --  Number of header slots; the first Num_Header_Slots slots are stored in
   --  the header; the rest are dynamically allocated in the Slots table. We
   --  need to subtract this off when accessing dynamic slots. The constant
   --  Seinfo.N_Head will contain this value. Fields that are allocated in the
   --  header slots are quicker to access.
   --
   --  This number can be adjusted for efficiency. We choose 3 because the
   --  minimum node size is 3 slots, and because that causes the size of type
   --  Node_Header to be a power of 2. We can't make it zero, however, because
   --  C doesn't allow zero-length arrays.

   N_Head : constant String := Image (Field_Offset'(Num_Header_Slots));
   --  String form of the above

   Enable_Assertions : constant Boolean := True;
   --  True to enable predicates on the _Id types, and preconditions on getters
   --  and setters.

   Overlay_Fields : constant Boolean := True;
   --  False to allocate every field so it doesn't overlay any other fields,
   --  which results in enormous nodes. For experimenting and debugging.
   --  Should be True in normal operation, for efficiency.

   SS : constant := 32; -- slot size in bits
   SSS : constant String := Image (Bit_Offset'(SS));

   Inline : constant String := "Inline";
   --  For experimenting with Inline_Always

   Syntactic : Fields_Per_Node_Type :=
     (others => (others => False));

   Nodes_And_Entities : constant Type_Vector := Node_Kind & Entity_Kind;
   All_Entities : constant Type_Vector := To_Vector (Entity_Kind, Length => 1);

   procedure Create_Type
     (T            : Node_Or_Entity_Type;
      Parent       : Opt_Abstract_Type;
      Fields       : Field_Sequence;
      Nmake_Assert : String);
   --  Called by the Create_..._Type procedures exported by this package to
   --  create an entry in the Types_Table.

   procedure Create_Union_Type
     (Root : Root_Type; T : Abstract_Type; Children : Type_Array);
   --  Called by Create_Node_Union_Type and Create_Entity_Union_Type to create
   --  a union type.

   function Create_Field
     (Field                 : Field_Enum;
      Field_Type            : Type_Enum;
      Default_Value         : Field_Default_Value;
      Type_Only             : Type_Only_Enum;
      Pre, Pre_Get, Pre_Set : String;
      Is_Syntactic          : Boolean) return Field_Desc;
   --  Called by the Create_..._Field functions exported by this package to
   --  create an entry in the Field_Table. See Create_Syntactic_Field and
   --  Create_Semantic_Field for additional doc.

   procedure Check_Type (T : Node_Or_Entity_Type);
   --  Check some "legality" rules for types in the Gen_IL little language

   ----------------
   -- Check_Type --
   ----------------

   procedure Check_Type (T : Node_Or_Entity_Type) is
      Im : constant String := Node_Or_Entity_Type'Image (T);
   begin
      if Type_Table (T) /= null then
         raise Illegal with "duplicate creation of type " & Image (T);
      end if;

      if T not in Root_Type then
         case T is
            when Node_Type =>
               if Im'Length < 2 or else Im (1 .. 2) /= "N_" then
                  raise Illegal with "Node type names must start with ""N_""";
               end if;

            when Concrete_Entity =>
               if Im'Length < 2 or else Im (1 .. 2) /= "E_" then
                  raise Illegal with
                    "Concrete entity type names must start with ""E_""";
               end if;

            when others => null;
               --  No special prefix for abstract entities
         end case;
      end if;
   end Check_Type;

   -----------------
   -- Create_Type --
   -----------------

   procedure Create_Type
     (T            : Node_Or_Entity_Type;
      Parent       : Opt_Abstract_Type;
      Fields       : Field_Sequence;
      Nmake_Assert : String)
   is
   begin
      Check_Type (T);

      if T not in Root_Type then
         if Type_Table (Parent) = null then
            raise Illegal with
              "undefined parent type for " &
              Image (T) & " (parent is " & Image (Parent) & ")";
         end if;

         if Type_Table (Parent).Is_Union then
            raise Illegal with
              "parent type for " &
                Image (T) & " must not be union (" & Image (Parent) & ")";
         end if;
      end if;

      Type_Table (T) :=
        new Type_Info'
          (Is_Union => False, Parent => Parent,
           Children | Concrete_Descendants => Type_Vectors.Empty_Vector,
           First | Last | Fields => <>, -- filled in later
           Nmake_Assert => new String'(Nmake_Assert));

      if Parent /= No_Type then
         Append (Type_Table (Parent).Children, T);
      end if;

      --  Check that syntactic fields precede semantic fields. Note that this
      --  check is happening before we compute inherited fields.
      --  Exempt Chars and Actions from this rule, for now.

      declare
         Semantic_Seen : Boolean := False;
      begin
         for J in Fields'Range loop
            if Fields (J).Is_Syntactic then
               if Semantic_Seen then
                  raise Illegal with
                    "syntactic fields must precede semantic ones " & Image (T);
               end if;

            else
               if Fields (J).F not in Chars | Actions then
                  Semantic_Seen := True;
               end if;
            end if;
         end loop;
      end;

      --  Check that node fields are in nodes, and entity fields are in
      --  entities.

      for J in Fields'Range loop
         declare
            Field : constant Field_Enum := Fields (J).F;
            Error_Prefix : constant String :=
              "Field " & Image (T) & "." & Image (Field) & " not in ";
         begin
            case T is
               when Node_Type =>
                  if Field not in Node_Field then
                     raise Illegal with Error_Prefix & "Node_Field";
                  end if;

               when Entity_Type =>
                  if Field not in Entity_Field then
                     raise Illegal with Error_Prefix & "Entity_Field";
                  end if;

               when Type_Boundaries =>
                  raise Program_Error; -- dummy types shouldn't have fields
            end case;
         end;
      end loop;

      --  Compute the Have_This_Field component of fields, the Fields component
      --  of the current type, and Syntactic table.

      for J in Fields'Range loop
         declare
            Field : constant Field_Enum := Fields (J).F;
            Is_Syntactic : constant Boolean := Fields (J).Is_Syntactic;

         begin
            Append (Field_Table (Field).Have_This_Field, T);
            Append (Type_Table (T).Fields, Field);

            pragma Assert (not Syntactic (T) (Field));
            Syntactic (T) (Field) := Is_Syntactic;
         end;
      end loop;
   end Create_Type;

   --  Other than constraint checks on T at the call site, and the lack of a
   --  parent for root types, the following six all do the same thing.

   ---------------------------
   -- Create_Root_Node_Type --
   ---------------------------

   procedure Create_Root_Node_Type
     (T      : Abstract_Node;
      Fields : Field_Sequence := No_Fields) is
   begin
      Create_Type (T, Parent => No_Type, Fields => Fields, Nmake_Assert => "");
   end Create_Root_Node_Type;

   -------------------------------
   -- Create_Abstract_Node_Type --
   -------------------------------

   procedure Create_Abstract_Node_Type
     (T      : Abstract_Node; Parent : Abstract_Type;
      Fields : Field_Sequence := No_Fields)
   is
   begin
      Create_Type (T, Parent, Fields, Nmake_Assert => "");
   end Create_Abstract_Node_Type;

   -------------------------------
   -- Create_Concrete_Node_Type --
   -------------------------------

   procedure Create_Concrete_Node_Type
     (T      : Concrete_Node; Parent : Abstract_Type;
      Fields : Field_Sequence := No_Fields;
      Nmake_Assert : String := "")
   is
   begin
      Create_Type (T, Parent, Fields, Nmake_Assert);
   end Create_Concrete_Node_Type;

   -----------------------------
   -- Create_Root_Entity_Type --
   -----------------------------

   procedure Create_Root_Entity_Type
     (T      : Abstract_Entity;
      Fields : Field_Sequence := No_Fields) is
   begin
      Create_Type (T, Parent => No_Type, Fields => Fields, Nmake_Assert => "");
   end Create_Root_Entity_Type;

   ---------------------------------
   -- Create_Abstract_Entity_Type --
   ---------------------------------

   procedure Create_Abstract_Entity_Type
     (T      : Abstract_Entity; Parent : Abstract_Type;
      Fields : Field_Sequence := No_Fields)
   is
   begin
      Create_Type (T, Parent, Fields, Nmake_Assert => "");
   end Create_Abstract_Entity_Type;

   ---------------------------------
   -- Create_Concrete_Entity_Type --
   ---------------------------------

   procedure Create_Concrete_Entity_Type
     (T      : Concrete_Entity; Parent : Abstract_Type;
      Fields : Field_Sequence := No_Fields)
   is
   begin
      Create_Type (T, Parent, Fields, Nmake_Assert => "");
   end Create_Concrete_Entity_Type;

   ------------------
   -- Create_Field --
   ------------------

   function Create_Field
     (Field                 : Field_Enum;
      Field_Type            : Type_Enum;
      Default_Value         : Field_Default_Value;
      Type_Only             : Type_Only_Enum;
      Pre, Pre_Get, Pre_Set : String;
      Is_Syntactic          : Boolean) return Field_Desc
   is
   begin
      --  Note that this function has the side effect of update the
      --  Field_Table.

      pragma Assert (if Default_Value /= No_Default then Is_Syntactic);
      pragma Assert (if Type_Only /= No_Type_Only then not Is_Syntactic);

      --  First time this field has been seen; create an entry in the
      --  Field_Table.

      if Field_Table (Field) = null then
         Field_Table (Field) := new Field_Info'
           (Type_Vectors.Empty_Vector, Field_Type, Default_Value, Type_Only,
            Pre => new String'(Pre),
            Pre_Get => new String'(Pre_Get),
            Pre_Set => new String'(Pre_Set),
            Offset => Unknown_Offset);

      --  The Field_Table entry has already been created by the 'then' part
      --  above. Now we're seeing the same field being "created" again in a
      --  different type. Here we check consistency of this new Create_Field
      --  call with the old one.

      else
         if Field_Type /= Field_Table (Field).Field_Type then
            raise Illegal with
              "mismatched field types for " & Image (Field);
         end if;

         --  Check that default values for syntactic fields match. This check
         --  could be stricter; it currently allows a field to have No_Default
         --  in one type, but something else in another type. In that case, we
         --  use the "something else" for all types.
         --
         --  Note that the order of calls does not matter; a default value
         --  always overrides a No_Default value.

         if Is_Syntactic then
            if Default_Value /= Field_Table (Field).Default_Value then
               if Field_Table (Field).Default_Value = No_Default then
                  Field_Table (Field).Default_Value := Default_Value;
               else
                  raise Illegal with
                    "mismatched default values for " & Image (Field);
               end if;
            end if;
         end if;

         if Type_Only /= Field_Table (Field).Type_Only then
            raise Illegal with "mismatched Type_Only for " & Image (Field);
         end if;

         if Pre /= Field_Table (Field).Pre.all then
            raise Illegal with
              "mismatched extra preconditions for " & Image (Field);
         end if;

         if Pre_Get /= Field_Table (Field).Pre_Get.all then
            raise Illegal with
              "mismatched extra getter-only preconditions for " &
              Image (Field);
         end if;

         if Pre_Set /= Field_Table (Field).Pre_Set.all then
            raise Illegal with
              "mismatched extra setter-only preconditions for " &
              Image (Field);
         end if;
      end if;

      return (Field, Is_Syntactic);
   end Create_Field;

   ----------------------------
   -- Create_Syntactic_Field --
   ----------------------------

   function Create_Syntactic_Field
     (Field      : Node_Field;
      Field_Type : Type_Enum;
      Default_Value : Field_Default_Value := No_Default;
      Pre, Pre_Get, Pre_Set : String := "") return Field_Desc
   is
   begin
      return Create_Field
        (Field, Field_Type, Default_Value, No_Type_Only,
         Pre, Pre_Get, Pre_Set,
         Is_Syntactic => True);
   end Create_Syntactic_Field;

   ---------------------------
   -- Create_Semantic_Field --
   ---------------------------

   function Create_Semantic_Field
     (Field      : Field_Enum;
      Field_Type : Type_Enum;
      Type_Only  : Type_Only_Enum := No_Type_Only;
      Pre, Pre_Get, Pre_Set : String := "") return Field_Desc
   is
   begin
      return Create_Field
        (Field, Field_Type, No_Default, Type_Only,
         Pre, Pre_Get, Pre_Set,
         Is_Syntactic => False);
   end Create_Semantic_Field;

   -----------------------
   -- Create_Union_Type --
   -----------------------

   procedure Create_Union_Type
     (Root : Root_Type; T : Abstract_Type; Children : Type_Array)
   is
      Children_Seen : Type_Set := (others => False);

   begin
      Check_Type (T);

      if Children'Length <= 1 then
         raise Illegal with Image (T) & " must have two or more children";
      end if;

      for Child of Children loop
         if Children_Seen (Child) then
            raise Illegal with
              Image (T) & " has duplicate child " & Image (Child);
         end if;

         Children_Seen (Child) := True;

         if Type_Table (Child) = null then
            raise Illegal with
              "undefined child type for " &
              Image (T) & " (child is " & Image (Child) & ")";
         end if;
      end loop;

      Type_Table (T) :=
        new Type_Info'
          (Is_Union => True, Parent => Root,
           Children | Concrete_Descendants => Type_Vectors.Empty_Vector);

      for Child of Children loop
         Append (Type_Table (T).Children, Child);
      end loop;
   end Create_Union_Type;

   ----------------------------
   -- Create_Node_Union_Type --
   ----------------------------

   procedure Create_Node_Union_Type
     (T : Abstract_Node; Children : Type_Array) is
   begin
      Create_Union_Type (Node_Kind, T, Children);
   end Create_Node_Union_Type;

   ------------------------------
   -- Create_Entity_Union_Type --
   ------------------------------

   procedure Create_Entity_Union_Type
     (T : Abstract_Entity; Children : Type_Array) is
   begin
      Create_Union_Type (Entity_Kind, T, Children);
   end Create_Entity_Union_Type;

   -------------
   -- Compile --
   -------------

   procedure Compile is
      Fields_Per_Node : Fields_Per_Node_Type := (others => (others => False));

      Type_Bit_Size : array (Concrete_Type) of Bit_Offset := (others => 0);
      Min_Node_Bit_Size : Bit_Offset := Bit_Offset'Last;
      Max_Node_Bit_Size : Bit_Offset := 0;
      Min_Entity_Bit_Size : Bit_Offset := Bit_Offset'Last;
      Max_Entity_Bit_Size : Bit_Offset := 0;
      --  Above are in units of bits; following are in units of slots:
      Min_Node_Size : Field_Offset := Field_Offset'Last;
      Max_Node_Size : Field_Offset := 0;
      Min_Entity_Size : Field_Offset := Field_Offset'Last;
      Max_Entity_Size : Field_Offset := 0;

      Node_Field_Types_Used, Entity_Field_Types_Used : Type_Set;

      Setter_Needs_Parent : Field_Set :=
        (Actions | Expression | Then_Actions | Else_Actions => True,
         others => False);
      --  Set of fields where the setter should set the Parent. True for
      --  syntactic fields of type Node_Id and List_Id, but with some
      --  exceptions. Expression is syntactic AND semantic, and the Parent
      --  is needed. Default_Expression is also both, but the Parent is not
      --  needed. Then_Actions and Else_Actions are not syntactic, but the
      --  Parent is needed.

      procedure Check_Completeness;
      --  Check that every type and field has been declared

      procedure Compute_Ranges (Root : Root_Type);
      --  Compute the range of Node_Kind/Entity_Kind values for all the types
      --  rooted at Root. The result is stored in the First and Last components
      --  in the Type_Table.

      procedure Compute_Fields_Per_Node;
      --  Compute which fields are in which nodes. Implements inheritance of
      --  fields. Set the Fields component of each Type_Info to include
      --  inherited ones. Set the Is_Syntactic component in the Type_Table to
      --  the set of fields that are syntactic in that node kind. Set the
      --  Fields_Per_Node table.

      procedure Compute_Field_Offsets;
      --  Compute the offsets of each field. The results are stored in the
      --  Offset components in the Field_Table.

      procedure Compute_Type_Sizes;
      --  Compute the size of each node and entity type, which is one more than
      --  the maximum bit offset of all fields of the type. Results are
      --  returned in the above Type_Bit_Size and Min_.../Max_... variables.

      procedure Check_For_Syntactic_Field_Mismatch;
      --  Check that fields are either all syntactic or all semantic in all
      --  nodes in which they exist, except for some fields that already
      --  violate this rule.
      --
      --  Also sets Setter_Needs_Parent.

      function Field_Types_Used (First, Last : Field_Enum) return Type_Set;
      --  Returns the union of the types of all the fields in the range First
      --  .. Last. Only Special_Type; if the declared type of a field is a
      --  descendant of Node_Kind or Entity_Kind, then the low-level getter for
      --  Node_Id can be used.

      procedure Put_Seinfo;
      --  Print out the Seinfo package, which is with'ed by both Sinfo.Nodes
      --  and Einfo.Entities.

      procedure Put_Nodes;
      --  Print out the Sinfo.Nodes package spec and body

      procedure Put_Entities;
      --  Print out the Einfo.Entities package spec and body

      procedure Put_Type_And_Subtypes
        (S : in out Sink; Root : Root_Type);
      --  Called by Put_Nodes and Put_Entities to print out the main type
      --  and subtype declarations in Sinfo.Nodes and Einfo.Entities.

      procedure Put_Subp_Decls (S : in out Sink; Root : Root_Type);
      --  Called by Put_Nodes and Put_Entities to print out the subprogram
      --  declarations in Sinfo.Nodes and Einfo.Entities.

      procedure Put_Subp_Bodies (S : in out Sink; Root : Root_Type);
      --  Called by Put_Nodes and Put_Entities to print out the subprogram
      --  bodies in Sinfo.Nodes and Einfo.Entities.

      function Node_To_Fetch_From (F : Field_Enum) return String;
      --  Name of the Node from which a getter should fetch the value.
      --  Normally, we fetch from the node or entity passed in (i.e. formal
      --  parameter N). But if Type_Only was specified, we need to fetch the
      --  corresponding base (etc) type.

      procedure Put_Getter_Spec (S : in out Sink; F : Field_Enum);
      procedure Put_Setter_Spec (S : in out Sink; F : Field_Enum);
      procedure Put_Getter_Decl (S : in out Sink; F : Field_Enum);
      procedure Put_Setter_Decl (S : in out Sink; F : Field_Enum);
      procedure Put_Getter_Setter_Locals
        (S : in out Sink; F : Field_Enum; Get : Boolean);
      procedure Put_Getter_Body (S : in out Sink; F : Field_Enum);
      procedure Put_Setter_Body (S : in out Sink; F : Field_Enum);
      --  Print out the specification, declaration, or body of a getter or
      --  setter for the given field.

      procedure Put_Precondition
        (S : in out Sink; F : Field_Enum);
      --  Print out the precondition, if any, for a getter or setter for the
      --  given field.

      procedure Put_Casts
        (S : in out Sink; T : Type_Enum);
      --  Print out the Cast functions for a given type

      procedure Put_Traversed_Fields (S : in out Sink);
      --  Called by Put_Nodes to print out the Traversed_Fields table in
      --  Sinfo.Nodes.

      procedure Put_Tables (S : in out Sink; Root : Root_Type);
      --  Called by Put_Nodes and Put_Entities to print out the various tables
      --  in Sinfo.Nodes and Einfo.Entities.

      procedure Put_Nmake;
      --  Print out the Nmake package spec and body, containing
      --  Make_... functions for each concrete node type.

      procedure Put_Make_Decls (S : in out Sink; Root : Root_Type);
      --  Called by Put_Nmake to print out the Make_... function declarations

      procedure Put_Make_Bodies (S : in out Sink; Root : Root_Type);
      --  Called by Put_Nmake to print out the Make_... function bodies

      procedure Put_Make_Spec
        (S : in out Sink; Root : Root_Type; T : Concrete_Type);
      --  Called by Put_Make_Decls and Put_Make_Bodies to print out the spec of
      --  a single Make_... function.

      procedure Put_Seinfo_Tables;
      --  This puts information about both sinfo and einfo.
      --  Not actually needed by the compiler.

      procedure Put_Sinfo_Dot_H;
      --  Print out the sinfo.h file

      procedure Put_Einfo_Dot_H;
      --  Print out the einfo.h file

      procedure Put_C_Type_And_Subtypes
        (S : in out Sink; Root : Root_Type);
      --  Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out the C code
      --  corresponding to the Ada Node_Kind, Entity_Kind, and subtypes
      --  thereof.

      procedure Put_C_Getters
        (S : in out Sink; Root : Root_Type);
      --  Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out high-level
      --  getters.

      procedure Put_C_Getter
        (S : in out Sink; F : Field_Enum);
      --  Used by Put_C_Getters to print out one high-level getter.

      procedure Put_Union_Membership
        (S : in out Sink; Root : Root_Type; Only_Prototypes : Boolean);
      --  Used by Put_Sinfo_Dot_H and Put_Einfo_Dot_H to print out functions to
      --  test membership in a union type.

      ------------------------
      -- Check_Completeness --
      ------------------------

      procedure Check_Completeness is
      begin
         for T in Node_Or_Entity_Type loop
            if Type_Table (T) = null and then T not in Type_Boundaries then
               raise Illegal with "Missing type declaration for " & Image (T);
            end if;
         end loop;

         for F in Field_Enum loop
            if Field_Table (F) = null
              and then F /= Between_Node_And_Entity_Fields
            then
               raise Illegal with "Missing field declaration for " & Image (F);
            end if;
         end loop;
      end Check_Completeness;

      --------------------
      -- Compute_Ranges --
      --------------------

      procedure Compute_Ranges (Root : Root_Type) is

         procedure Do_One_Type (T : Node_Or_Entity_Type);
         --  Compute the range for one type. Passed to Iterate_Types to process
         --  all of them.

         procedure Add_Concrete_Descendant_To_Ancestors
           (Ancestor : Abstract_Type; Descendant : Concrete_Type);
         --  Add Descendant to the Concrete_Descendants of each of its
         --  ancestors.

         procedure Add_Concrete_Descendant_To_Ancestors
           (Ancestor : Abstract_Type; Descendant : Concrete_Type) is
         begin
            if Ancestor not in Root_Type then
               Add_Concrete_Descendant_To_Ancestors
                 (Type_Table (Ancestor).Parent, Descendant);
            end if;

            Append (Type_Table (Ancestor).Concrete_Descendants, Descendant);
         end Add_Concrete_Descendant_To_Ancestors;

         procedure Do_One_Type (T : Node_Or_Entity_Type) is
         begin
            case T is
               when Concrete_Type =>
                  pragma Annotate (Codepeer, Modified, Type_Table);
                  Type_Table (T).First := T;
                  Type_Table (T).Last  := T;
                  Add_Concrete_Descendant_To_Ancestors
                    (Type_Table (T).Parent, T);
                  --  Parent cannot be No_Type here, because T is a concrete
                  --  type, and therefore not a root type.

               when Abstract_Type =>
                  declare
                     Children : Type_Vector renames Type_Table (T).Children;
                  begin
                     --  Ensure that an abstract type is not a leaf in the type
                     --  hierarchy.

                     if Is_Empty (Children) then
                        raise Illegal with Image (T) & " has no children";
                     end if;

                     --  We could support abstract types with only one child,
                     --  but what's the point of having such a type?

                     if Last_Index (Children) = 1 then
                        raise Illegal with Image (T) & " has only one child";
                     end if;

                     Type_Table (T).First := Type_Table (Children (1)).First;
                     Type_Table (T).Last  :=
                       Type_Table (Children (Last_Index (Children))).Last;
                  end;

               when Between_Abstract_Entity_And_Concrete_Node_Types =>
                  raise Program_Error;
            end case;
         end Do_One_Type;
      begin
         Iterate_Types (Root, Post => Do_One_Type'Access);
      end Compute_Ranges;

      -----------------------------
      -- Compute_Fields_Per_Node --
      -----------------------------

      procedure Compute_Fields_Per_Node is

         Duplicate_Fields_Found : Boolean := False;

         function Get_Fields (T : Node_Or_Entity_Type) return Field_Vector;
         --  Compute the fields of a given type. This is the fields inherited
         --  from ancestors, plus the fields declared for the type itself.

         function Get_Syntactic_Fields
           (T : Node_Or_Entity_Type) return Field_Set;
         --  Compute the set of fields that are syntactic for a given type.
         --  Note that a field can be syntactic in some node types, but
         --  semantic in others.

         procedure Do_Concrete_Type (CT : Concrete_Type);
         --  Do the Compute_Fields_Per_Node work for a concrete type

         function Get_Fields (T : Node_Or_Entity_Type) return Field_Vector is
            Parent_Fields : constant Field_Vector :=
              (if T in Root_Type then Field_Vectors.Empty_Vector
               else Get_Fields (Type_Table (T).Parent));
         begin
            return Parent_Fields & Type_Table (T).Fields;
         end Get_Fields;

         function Get_Syntactic_Fields
           (T : Node_Or_Entity_Type) return Field_Set
         is
            Parent_Is_Syntactic : constant Field_Set :=
              (if T in Root_Type then (Field_Enum => False)
               else Get_Syntactic_Fields (Type_Table (T).Parent));
         begin
            return Parent_Is_Syntactic or Syntactic (T);
         end Get_Syntactic_Fields;

         procedure Do_Concrete_Type (CT : Concrete_Type) is
         begin
            Type_Table (CT).Fields := Get_Fields (CT);
            Syntactic (CT) := Get_Syntactic_Fields (CT);

            for F of Type_Table (CT).Fields loop
               if Fields_Per_Node (CT) (F) then
                  Ada.Text_IO.Put_Line
                    ("duplicate field" & Image (CT) & Image (F));
                  Duplicate_Fields_Found := True;
               end if;

               Fields_Per_Node (CT) (F) := True;
            end loop;
         end Do_Concrete_Type;

      begin -- Compute_Fields_Per_Node
         for CT in Concrete_Node loop
            Do_Concrete_Type (CT);
         end loop;

         --  The node fields defined for all three N_Entity kinds should be the
         --  same:

         if Type_Table (N_Defining_Character_Literal).Fields /=
           Type_Table (N_Defining_Identifier).Fields
         then
            raise Illegal with
              "fields for N_Defining_Identifier and " &
              "N_Defining_Character_Literal must match";
         end if;

         if Type_Table (N_Defining_Operator_Symbol).Fields /=
           Type_Table (N_Defining_Identifier).Fields
         then
            raise Illegal with
              "fields for N_Defining_Identifier and " &
              "N_Defining_Operator_Symbol must match";
         end if;

         if Fields_Per_Node (N_Defining_Character_Literal) /=
           Fields_Per_Node (N_Defining_Identifier)
         then
            raise Illegal with
              "Fields of N_Defining_Character_Literal must match " &
              "N_Defining_Identifier";
         end if;

         if Fields_Per_Node (N_Defining_Operator_Symbol) /=
           Fields_Per_Node (N_Defining_Identifier)
         then
            raise Illegal with
              "Fields of N_Defining_Operator_Symbol must match " &
              "N_Defining_Identifier";
         end if;

         --  Copy node fields from N_Entity nodes to entities, so they have
         --  slots allocated (but the getters and setters are only in
         --  Sinfo.Nodes).

         Type_Table (Entity_Kind).Fields :=
           Type_Table (N_Defining_Identifier).Fields &
           Type_Table (Entity_Kind).Fields;

         for CT in Concrete_Entity loop
            Do_Concrete_Type (CT);
         end loop;

         if Duplicate_Fields_Found then
            raise Illegal with "duplicate fields found";
         end if;
      end Compute_Fields_Per_Node;

      function Field_Size (T : Type_Enum) return Bit_Offset is
        (case T is
          when Flag => 1,

          when Small_Paren_Count_Type | Component_Alignment_Kind => 2,

          when Node_Kind_Type | Entity_Kind_Type | Convention_Id => 8,

          when Mechanism_Type
             | List_Id
             | Elist_Id
             | Name_Id
             | String_Id
             | Uint
             | Uint_Subtype
             | Ureal
             | Source_Ptr
             | Union_Id
             | Node_Id
             | Node_Or_Entity_Type => 32,

         when Between_Special_And_Abstract_Node_Types => -- can't happen
           Bit_Offset'Last);
         --  Size in bits of a a field of type T. It must be a power of 2, and
         --  must match the size of the type in GNAT, which sometimes requires
         --  a Size clause in GNAT.
         --
         --  Note that this is not the same as Type_Bit_Size of the field's
         --  type. For one thing, Type_Bit_Size only covers concrete node and
         --  entity types, which does not include most of the above. For
         --  another thing, Type_Bit_Size includes the full size of all the
         --  fields, whereas a field of a node or entity type is just a 32-bit
         --  Node_Id or Entity_Id; i.e. it is indirect.

      function Field_Size (F : Field_Enum) return Bit_Offset is
        (Field_Size (Field_Table (F).Field_Type));

      function To_Bit_Offset (F : Field_Enum; Offset : Field_Offset'Base)
        return Bit_Offset'Base is
          (Bit_Offset'Base (Offset) * Field_Size (F));
      function First_Bit (F : Field_Enum; Offset : Field_Offset)
        return Bit_Offset is
          (To_Bit_Offset (F, Offset));
      function Last_Bit (F : Field_Enum; Offset : Field_Offset)
        return Bit_Offset is
          (To_Bit_Offset (F, Offset + 1) - 1);

      function To_Size_In_Slots (Size_In_Bits : Bit_Offset)
        return Field_Offset is
          ((Field_Offset (Size_In_Bits) + (SS - 1)) / SS);

      function Type_Size_In_Slots (T : Concrete_Type) return Field_Offset is
        (To_Size_In_Slots (Type_Bit_Size (T))); -- rounded up to slot boundary

      function Type_Bit_Size_Aligned (T : Concrete_Type) return Bit_Offset is
        (Bit_Offset (Type_Size_In_Slots (T)) * SS); -- multiple of slot size

      ---------------------------
      -- Compute_Field_Offsets --
      ---------------------------

      procedure Compute_Field_Offsets is
         type Offset_Set_Unconstrained is array (Bit_Offset range <>)
           of Boolean with Pack;
         subtype Offset_Set is Offset_Set_Unconstrained (Bit_Offset);
         Offset_Sets : array (Concrete_Type) of Offset_Set :=
           (others => (others => False));

         function All_False
           (F : Field_Enum; Offset : Field_Offset)
           return Offset_Set_Unconstrained is
             (First_Bit (F, Offset) .. Last_Bit (F, Offset) => False);

         function All_True
           (F : Field_Enum; Offset : Field_Offset)
           return Offset_Set_Unconstrained is
             (First_Bit (F, Offset) .. Last_Bit (F, Offset) => True);

         function Offset_OK
           (F : Field_Enum; Offset : Field_Offset) return Boolean;
         --  True if it is OK to choose this offset; that is, if this offset is
         --  not in use for any type that has the field. If Overlay_Fields is
         --  False, then "any type that has the field" --> "any type, whether
         --  or not it has the field".

         procedure Set_Offset_In_Use
           (F : Field_Enum; Offset : Field_Offset);
         --  Mark the offset as "in use"

         procedure Choose_Offset (F : Field_Enum);
         --  Choose an offset for this field

         function Offset_OK
           (F : Field_Enum; Offset : Field_Offset) return Boolean is
         begin
            for T in Concrete_Type loop
               if Fields_Per_Node (T) (F) or else not Overlay_Fields then
                  declare
                     Bits : Offset_Set_Unconstrained renames
                       Offset_Sets (T)
                         (First_Bit (F, Offset) .. Last_Bit (F, Offset));
                  begin
                     if Bits /= All_False (F, Offset) then
                        return False;
                     end if;
                  end;
               end if;
            end loop;

            return True;
         end Offset_OK;

         procedure Set_Offset_In_Use
           (F : Field_Enum; Offset : Field_Offset) is
         begin
            for T in Concrete_Type loop
               if Fields_Per_Node (T) (F) then
                  declare
                     Bits : Offset_Set_Unconstrained renames
                       Offset_Sets (T)
                         (First_Bit (F, Offset) .. Last_Bit (F, Offset));
                  begin
                     pragma Assert (Bits = All_False (F, Offset));
                     Bits := All_True (F, Offset);
                  end;
               end if;
            end loop;
         end Set_Offset_In_Use;

         procedure Choose_Offset (F : Field_Enum) is
         begin
            for Offset in Field_Offset loop
               if Offset_OK (F, Offset) then
                  Set_Offset_In_Use (F, Offset);

                  Field_Table (F).Offset := Offset;
                  return;
               end if;
            end loop;

            raise Illegal with "No available field offset for " & Image (F) &
              "; need to increase Gen_IL.Internals.Bit_Offset'Last (" &
              Image (Gen_IL.Internals.Bit_Offset'Last) & " is too small)";
         end Choose_Offset;

         Weighted_Node_Frequency : array (Field_Enum) of Type_Count :=
           (others => 0);
         --  Number of concrete types that have each field

         function More_Types_Have_Field (F1, F2 : Field_Enum) return Boolean is
           (Weighted_Node_Frequency (F1) > Weighted_Node_Frequency (F2));
         --  True if F1 appears in more concrete types than F2

         function Sort_Less (F1, F2 : Field_Enum) return Boolean is
           (if Weighted_Node_Frequency (F1) = Weighted_Node_Frequency (F2) then
              F1 < F2
            else More_Types_Have_Field (F1, F2));

         package Sorting is new Field_Vectors.Generic_Sorting
           ("<" => Sort_Less);

         All_Fields : Field_Vector;

      --  Start of processing for Compute_Field_Offsets

      begin

         --  Compute the number of types that have each field, weighted by the
         --  frequency of such nodes.

         for T in Concrete_Type loop
            for F in Field_Enum loop
               if Fields_Per_Node (T) (F) then
                  Weighted_Node_Frequency (F) :=
                    Weighted_Node_Frequency (F) + Type_Frequency (T);
               end if;
            end loop;
         end loop;

         --  Collect all the fields in All_Fields

         for F in Node_Field loop
            Append (All_Fields, F);
         end loop;

         for F in Entity_Field loop
            Append (All_Fields, F);
         end loop;

         --  Sort All_Fields based on how many concrete types have the field.
         --  This is for efficiency; we want to choose the offsets of the most
         --  common fields first, so they get low numbers.

         Sorting.Sort (All_Fields);

         --  Go through all the fields, and choose the lowest offset that is
         --  free in all types that have the field. This is basically a
         --  graph-coloring algorithm on the interference graph. The
         --  interference graph is an undirected graph with the fields being
         --  nodes (not nodes in the compiler!) in the graph, and an edge
         --  between a pair of fields if they appear in the same node in the
         --  compiler. The "colors" are fields offsets, except that a
         --  complication compared to standard graph coloring is that fields
         --  are different sizes.

         --  First choose offsets for some heavily-used fields, so they will
         --  get low offsets, so they will wind up in the node header for
         --  faster access.

         Choose_Offset (Nkind);
         pragma Assert (Field_Table (Nkind).Offset = 0);
         Choose_Offset (Ekind);
         pragma Assert (Field_Table (Ekind).Offset = 1);
         Choose_Offset (Homonym);
         pragma Assert (Field_Table (Homonym).Offset = 1);
         Choose_Offset (Is_Immediately_Visible);
         pragma Assert (Field_Table (Is_Immediately_Visible).Offset = 16);
         Choose_Offset (From_Limited_With);
         pragma Assert (Field_Table (From_Limited_With).Offset = 17);
         Choose_Offset (Is_Potentially_Use_Visible);
         pragma Assert (Field_Table (Is_Potentially_Use_Visible).Offset = 18);
         Choose_Offset (Is_Generic_Instance);
         pragma Assert (Field_Table (Is_Generic_Instance).Offset = 19);
         Choose_Offset (Scope);
         pragma Assert (Field_Table (Scope).Offset = 2);

         --  Then loop through them all, skipping the ones we did above

         for F of All_Fields loop
            if Field_Table (F).Offset = Unknown_Offset then
               Choose_Offset (F);
            end if;
         end loop;

      end Compute_Field_Offsets;

      ------------------------
      -- Compute_Type_Sizes --
      ------------------------

      procedure Compute_Type_Sizes is
      begin
         for T in Concrete_Type loop
            declare
               Max_Offset : Bit_Offset := 0;

            begin
               for F in Field_Enum loop
                  if Fields_Per_Node (T) (F) then
                     Max_Offset :=
                       Bit_Offset'Max
                         (Max_Offset,
                          To_Bit_Offset (F, Field_Table (F).Offset));
                  end if;
               end loop;

               --  No type can be smaller than the header slots

               Type_Bit_Size (T) :=
                 Bit_Offset'Max (Max_Offset + 1, SS * Num_Header_Slots);
            end;
         end loop;

         for T in Concrete_Node loop
            Min_Node_Bit_Size :=
              Bit_Offset'Min (Min_Node_Bit_Size, Type_Bit_Size (T));
            Max_Node_Bit_Size :=
              Bit_Offset'Max (Max_Node_Bit_Size, Type_Bit_Size (T));
         end loop;

         for T in Concrete_Entity loop
            Min_Entity_Bit_Size :=
              Bit_Offset'Min (Min_Entity_Bit_Size, Type_Bit_Size (T));
            Max_Entity_Bit_Size :=
              Bit_Offset'Max (Max_Entity_Bit_Size, Type_Bit_Size (T));
         end loop;

         Min_Node_Size := To_Size_In_Slots (Min_Node_Bit_Size);
         Max_Node_Size := To_Size_In_Slots (Max_Node_Bit_Size);
         Min_Entity_Size := To_Size_In_Slots (Min_Entity_Bit_Size);
         Max_Entity_Size := To_Size_In_Slots (Max_Entity_Bit_Size);
      end Compute_Type_Sizes;

      ----------------------------------------
      -- Check_For_Syntactic_Field_Mismatch --
      ----------------------------------------

      procedure Check_For_Syntactic_Field_Mismatch is
      begin
         for F in Field_Enum loop
            if F /= Between_Node_And_Entity_Fields then
               declare
                  Syntactic_Seen, Semantic_Seen : Boolean := False;
                  Have_Field : Type_Vector renames
                    Field_Table (F).Have_This_Field;

               begin
                  for J in 1 .. Last_Index (Have_Field) loop
                     if Syntactic (Have_Field (J)) (F) then
                        Syntactic_Seen := True;
                     else
                        Semantic_Seen := True;
                     end if;
                  end loop;

                  --  The following fields violate this rule. We might want to
                  --  simplify by getting rid of these cases, but we allow them
                  --  for now. At least, we don't want to add any new cases of
                  --  syntactic/semantic mismatch.

                  if F in Chars | Actions | Expression | Default_Expression
                  then
                     pragma Assert (Syntactic_Seen and Semantic_Seen);

                  else
                     if Syntactic_Seen and Semantic_Seen then
                        raise Illegal with
                          "syntactic/semantic mismatch for " & Image (F);
                     end if;

                     if Field_Table (F).Field_Type in Traversed_Field_Type
                       and then Syntactic_Seen
                     then
                        Setter_Needs_Parent (F) := True;
                     end if;
                  end if;
               end;
            end if;
         end loop;
      end Check_For_Syntactic_Field_Mismatch;

      ----------------------
      -- Field_Types_Used --
      ----------------------

      function Field_Types_Used (First, Last : Field_Enum) return Type_Set is
         Result : Type_Set := (others => False);
      begin
         for F in First .. Last loop
            if Field_Table (F).Field_Type in Node_Or_Entity_Type then
               Result (Node_Id) := True;
            else
               Result (Field_Table (F).Field_Type) := True;
            end if;
         end loop;

         return Result;
      end Field_Types_Used;

      pragma Style_Checks ("M120");
      --  Lines of the form Put (S, "..."); are more readable if we relax the
      --  line length. We really just want the "..." to be short enough.

      ---------------------------
      -- Put_Type_And_Subtypes --
      ---------------------------

      procedure Put_Type_And_Subtypes
        (S : in out Sink; Root : Root_Type)
      is

         procedure Put_Enum_Type;
         --  Print out the enumeration type declaration for a root type
         --  (Node_Kind or Entity_Kind).

         procedure Put_Kind_Subtype (T : Node_Or_Entity_Type);
         --  Print out a subrange (of type Node_Kind or Entity_Kind) for a
         --  given nonroot abstract type.

         procedure Put_Id_Subtype (T : Node_Or_Entity_Type);
         --  Print out a subtype (of type Node_Id or Entity_Id) for a given
         --  nonroot abstract type.

         procedure Put_Opt_Subtype (T : Node_Or_Entity_Type);
         --  Print out an "optional" subtype; that is, one that allows
         --  Empty. Their names start with "Opt_".

         procedure Put_Enum_Type is
            procedure Put_Enum_Lit (T : Node_Or_Entity_Type);
            --  Print out one enumeration literal in the declaration of
            --  Node_Kind or Entity_Kind.

            First_Time : Boolean := True;

            procedure Put_Enum_Lit (T : Node_Or_Entity_Type) is
            begin
               if T in Concrete_Type then
                  if First_Time then
                     First_Time := False;
                  else
                     Put (S, "," & LF);
                  end if;

                  Put (S, Image (T));
               end if;
            end Put_Enum_Lit;

            type Dummy is array
              (First_Concrete (Root) .. Last_Concrete (Root)) of Boolean;
            Num_Types : constant Root_Int := Dummy'Length;

         begin
            Put (S, "type " & Image (Root) & " is -- " &
                    Image (Num_Types) & " " & Image (Root) & "s" & LF);
            Increase_Indent (S, 2);
            Put (S, "(");
            Increase_Indent (S, 1);
            Iterate_Types (Root, Pre => Put_Enum_Lit'Access);
            Decrease_Indent (S, 1);
            Put (S, LF & ") with Size => 8; -- " & Image (Root) & LF & LF);
            Decrease_Indent (S, 2);
         end Put_Enum_Type;

         procedure Put_Kind_Subtype (T : Node_Or_Entity_Type) is
         begin
            if T in Abstract_Type then
               if Type_Table (T).Is_Union then
                  pragma Assert (Type_Table (T).Parent = Root);

                  Put (S, "subtype " & Image (T) & " is" & LF);
                  Increase_Indent (S, 2);
                  Put (S, Image (Root) & " with Predicate =>" & LF);
                  Increase_Indent (S, 2);
                  Put (S, Image (T) & " in" & LF);
                  Put_Types_With_Bars (S, Type_Table (T).Children);
                  Decrease_Indent (S, 2);
                  Put (S, ";" & LF);
                  Decrease_Indent (S, 2);

               elsif Type_Table (T).Parent /= No_Type then
                  Put (S, "subtype " & Image (T) & " is " &
                       Image (Type_Table (T).Parent) & " range" & LF);
                  Increase_Indent (S, 2);
                  Put (S, Image (Type_Table (T).First) & " .. " &
                          Image (Type_Table (T).Last) & ";" & LF);
                  Decrease_Indent (S, 2);

                  Increase_Indent (S, 3);

                  for J in 1 .. Type_Table (T).Concrete_Descendants.Last_Index loop
                     Put (S, "--  " &
                          Image (Type_Table (T).Concrete_Descendants (J)) & LF);
                  end loop;

                  Decrease_Indent (S, 3);
               end if;
            end if;
         end Put_Kind_Subtype;

         procedure Put_Id_Subtype (T : Node_Or_Entity_Type) is
         begin
            if Type_Table (T).Parent /= No_Type then
               Put (S, "subtype " & Id_Image (T) & " is" & LF);
               Increase_Indent (S, 2);
               Put (S, Id_Image (Type_Table (T).Parent));

               if Enable_Assertions then
                  Put (S, " with Predicate =>" & LF);
                  Increase_Indent (S, 2);
                  Put (S, "K (" & Id_Image (T) & ") in " & Image (T));
                  Decrease_Indent (S, 2);
               end if;

               Put (S, ";" & LF);
               Decrease_Indent (S, 2);
            end if;
         end Put_Id_Subtype;

         procedure Put_Opt_Subtype (T : Node_Or_Entity_Type) is
         begin
            if Type_Table (T).Parent /= No_Type then
               Put (S, "subtype Opt_" & Id_Image (T) & " is" & LF);
               Increase_Indent (S, 2);
               Put (S, Id_Image (Root));

               --  Assert that the Opt_XXX subtype is empty or in the XXX
               --  subtype.

               if Enable_Assertions then
                  Put (S, " with Predicate =>" & LF);
                  Increase_Indent (S, 2);
                  Put (S, "Opt_" & Id_Image (T) & " = Empty or else" & LF);
                  Put (S, "Opt_" & Id_Image (T) & " in " & Id_Image (T));
                  Decrease_Indent (S, 2);
               end if;

               Put (S, ";" & LF);
               Decrease_Indent (S, 2);
            end if;
         end Put_Opt_Subtype;

      begin -- Put_Type_And_Subtypes
         Put_Enum_Type;

         --  Put the getter for Nkind and Ekind here, earlier than the other
         --  getters, because it is needed in predicates of the following
         --  subtypes.

         case Root is
            when Node_Kind =>
               Put_Getter_Decl (S, Nkind);
               Put (S, "function K (N : Node_Id) return Node_Kind renames " & Image (Nkind) & ";" & LF);
               Put (S, "--  Shorthand for use in predicates and preconditions below" & LF);
               Put (S, "--  There is no procedure Set_Nkind." & LF);
               Put (S, "--  See Init_Nkind and Mutate_Nkind in Atree." & LF & LF);

            when Entity_Kind =>
               Put_Getter_Decl (S, Ekind);
               Put (S, "function K (N : Entity_Id) return Entity_Kind renames Ekind;" & LF);
               Put (S, "--  Shorthand for use in predicates and preconditions below" & LF);
               Put (S, "--  There is no procedure Set_Ekind here." & LF);
               Put (S, "--  See Mutate_Ekind in Atree." & LF & LF);

            when others => raise Program_Error;
         end case;

         Put (S, "--  Subtypes of " & Image (Root) & " for each abstract type:" & LF & LF);

         Put (S, "pragma Style_Checks (""M200"");" & LF);
         Iterate_Types (Root, Pre => Put_Kind_Subtype'Access);

         Put (S, LF & "--  Subtypes of " & Id_Image (Root) &
              " with specified " & Image (Root) & "." & LF);
         Put (S, "--  These may be used in place of " & Id_Image (Root) &
              " for better documentation," & LF);
         Put (S, "--  and if assertions are enabled, for run-time checking." & LF & LF);

         Iterate_Types (Root, Pre => Put_Id_Subtype'Access);

         Put (S, LF & "--  Union types (nonhierarchical subtypes of " &
              Id_Image (Root) & ")" & LF & LF);

         for T in First_Abstract (Root) .. Last_Abstract (Root) loop
            if Type_Table (T) /= null and then Type_Table (T).Is_Union then
               Put_Kind_Subtype (T);
               Put_Id_Subtype (T);
            end if;
         end loop;

         Put (S, LF & "--  Optional subtypes of " & Id_Image (Root) & "." &
              " These allow Empty." & LF & LF);

         Iterate_Types (Root, Pre => Put_Opt_Subtype'Access);

         Put (S, LF & "--  Optional union types:" & LF & LF);

         for T in First_Abstract (Root) .. Last_Abstract (Root) loop
            if Type_Table (T) /= null and then Type_Table (T).Is_Union then
               Put_Opt_Subtype (T);
            end if;
         end loop;

         Put (S, LF & "subtype Flag is Boolean;" & LF & LF);
      end Put_Type_And_Subtypes;

      -------------------------------------------
      -- Put_Casts --
      -------------------------------------------

      procedure Put_Casts
        (S : in out Sink; T : Type_Enum)
      is
         Pre : constant String :=
           "function Cast is new Unchecked_Conversion (";
         Lo_Type : constant String := "Field_Size_" & Image (Field_Size (T)) & "_Bit";
         Hi_Type : constant String := Get_Set_Id_Image (T);
      begin
         if T not in Uint_Subtype then
            if T not in Node_Kind_Type | Entity_Kind_Type then
               Put (S, Pre & Hi_Type & ", " & Lo_Type & ");" & LF);
            end if;

            Put (S, Pre & Lo_Type & ", " & Hi_Type & ");" & LF);
         end if;
      end Put_Casts;

      ----------------------
      -- Put_Precondition --
      ----------------------

      procedure Put_Precondition
        (S : in out Sink; F : Field_Enum)
      is
         --  If the field is present in all entities, we want to assert that
         --  N in N_Entity_Id. If the field is present in only some entities,
         --  we don't need that, because we are fetching Ekind in that case,
         --  which will assert N in N_Entity_Id.

         Is_Entity : constant String :=
           (if Field_Table (F).Have_This_Field = All_Entities then
             "N in N_Entity_Id"
            else "");
      begin
         --  If this is an entity field, then we should assert that N is an
         --  entity. We need "N in A | B | ..." unless this is embodied in a
         --  subtype predicate.
         --
         --  We can't put the extra "Pre => ..." specified on the call to
         --  Create_..._Field as part of the precondition, because some of
         --  them call things that are not visible here.

         if Enable_Assertions then
            if Length (Field_Table (F).Have_This_Field) = 1
              or else Field_Table (F).Have_This_Field = Nodes_And_Entities
            then
               if Is_Entity /= "" then
                  Increase_Indent (S, 1);
                  Put (S, ", Pre =>" & LF);
                  Put (S, Is_Entity);
                  Decrease_Indent (S, 1);
               end if;

            else
               Put (S, ", Pre =>" & LF);
               Increase_Indent (S, 1);
               Put (S, "N in ");
               Put_Type_Ids_With_Bars (S, Field_Table (F).Have_This_Field);

               pragma Assert (Is_Entity = "");

               Decrease_Indent (S, 1);
            end if;
         end if;
      end Put_Precondition;

      function Root_Type_For_Field (F : Field_Enum) return Root_Type is
        (case F is
           when Node_Field           => Node_Kind,
           when Entity_Field         => Entity_Kind,
           when Between_Node_And_Entity_Fields => Node_Kind); -- can't happen

      function N_Type (F : Field_Enum) return String is
        (if Length (Field_Table (F).Have_This_Field) = 1 then
          Id_Image (Field_Table (F).Have_This_Field (1))
         else Id_Image (Root_Type_For_Field (F)));
      --  Name of the parameter type of the N parameter of the getter and
      --  setter for field F. If there's only one Have_This_Field, use that;
      --  the predicate will check for the right Kind. Otherwise, we use
      --  Node_Id or Entity_Id, and the getter and setter will have
      --  preconditions.

      procedure Put_Get_Set_Incr
        (S : in out Sink; F : Field_Enum; Get_Or_Set : String)
        with Pre => Get_Or_Set in "Get" | "Set";
      --  If statistics are enabled, put the appropriate increment statement

      ----------------------
      -- Put_Get_Set_Incr --
      ----------------------

      procedure Put_Get_Set_Incr
        (S : in out Sink; F : Field_Enum; Get_Or_Set : String) is
      begin
         if Statistics_Enabled then
            Put (S, "Atree." & Get_Or_Set & "_Count (" & F_Image (F) &
                   ") := Atree." & Get_Or_Set & "_Count (" &
                   F_Image (F) & ") + 1;" & LF);
         end if;
      end Put_Get_Set_Incr;

      ------------------------
      -- Node_To_Fetch_From --
      ------------------------

      function Node_To_Fetch_From (F : Field_Enum) return String is
      begin
         return
           (case Field_Table (F).Type_Only is
              when No_Type_Only => "N",
              when Base_Type_Only => "Base_Type (N)",
              when Impl_Base_Type_Only => "Implementation_Base_Type (N)",
              when Root_Type_Only => "Root_Type (N)");
      end Node_To_Fetch_From;

      ---------------------
      -- Put_Getter_Spec --
      ---------------------

      procedure Put_Getter_Spec (S : in out Sink; F : Field_Enum) is
      begin
         Put (S, "function " & Image (F));
         Put (S, " (N : " & N_Type (F) & ") return " &
              Get_Set_Id_Image (Field_Table (F).Field_Type));
      end Put_Getter_Spec;

      ---------------------
      -- Put_Getter_Decl --
      ---------------------

      procedure Put_Getter_Decl (S : in out Sink; F : Field_Enum) is
      begin
         Put_Getter_Spec (S, F);
         Put (S, " with " & Inline);
         Increase_Indent (S, 2);
         Put_Precondition (S, F);
         Decrease_Indent (S, 2);
         Put (S, ";" & LF);
      end Put_Getter_Decl;

      ------------------------------
      -- Put_Getter_Setter_Locals --
      ------------------------------

      procedure Put_Getter_Setter_Locals
        (S : in out Sink; F : Field_Enum; Get : Boolean)
      is
         Rec : Field_Info renames Field_Table (F).all;

         F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type);
         Off : constant Field_Offset := Rec.Offset;
         F_Per_Slot : constant Field_Offset :=
           SS / Field_Offset (Field_Size (Rec.Field_Type));
         Slot_Off : constant Field_Offset := Off / F_Per_Slot;
         In_NH : constant Boolean := Slot_Off < Num_Header_Slots;

         N : constant String :=
           (if Get then Node_To_Fetch_From (F) else "N");

      begin
         Put (S, " is" & LF);
         Increase_Indent (S, 3);
         Put (S, "--  " & Image (F_Per_Slot) & "  " & Image (F_Size) &
                "-bit fields per " & SSS & "-bit slot." & LF);
         Put (S, "--  Offset " & Image (Off) & " = " &
                Image (Slot_Off) & " slots + " & Image (Off mod F_Per_Slot) &
                " fields in slot." & LF & LF);

         Put (S, "Off : constant := " & Image (Off) & ";" & LF);
         Put (S, "F_Size : constant := " & Image (F_Size) & ";" & LF);

         if Field_Size (Rec.Field_Type) /= SS then
            Put (S, "Mask : constant := 2**F_Size - 1;" & LF);
         end if;

         Put (S, "F_Per_Slot : constant Field_Offset := Slot_Size / F_Size;" & LF);
         Put (S, "Slot_Off : constant Field_Offset := Off / F_Per_Slot;" & LF);

         if In_NH then
            Put (S, "S : Slot renames Node_Offsets.Table (" & N & ").Slots (Slot_Off);" & LF);
         else
            Put (S, "S : Slot renames Slots.Table (Node_Offsets.Table (" & N & ").Offset + Slot_Off);" & LF);
         end if;

         if Field_Size (Rec.Field_Type) /= SS then
            Put (S, "V : constant Natural := Natural ((Off mod F_Per_Slot) * F_Size);" & LF);
            Put (S, LF);
         end if;
      end Put_Getter_Setter_Locals;

      ---------------------
      -- Put_Getter_Body --
      ---------------------

      procedure Put_Getter_Body (S : in out Sink; F : Field_Enum) is
         Rec : Field_Info renames Field_Table (F).all;
         F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type);
         T : constant String := Get_Set_Id_Image (Rec.Field_Type);
      begin
         --  Note that we store the result in a local constant below, so that
         --  the "Pre => ..." can refer to it. The constant is called Val so
         --  that it has the same name as the formal of the setter, so the
         --  "Pre => ..." can refer to it by the same name in both getter
         --  and setter.

         Put_Getter_Spec (S, F);
         Put_Getter_Setter_Locals (S, F, Get => True);

         Put (S, "Raw : constant Field_Size_" & Image (F_Size) & "_Bit :=" & LF);
         Increase_Indent (S, 2);
         Put (S, "Field_Size_" & Image (F_Size) & "_Bit (");

         if Field_Size (Rec.Field_Type) /= SS then
            Put (S, "Shift_Right (S, V) and Mask);" & LF);
         else
            Put (S, "S);" & LF);
         end if;

         Decrease_Indent (S, 2);

         Put (S, "Val : constant " & T & " :=");

         if Field_Has_Special_Default (Rec.Field_Type) then
            pragma Assert (Field_Size (Rec.Field_Type) = 32);
            Put (S, LF);
            Increase_Indent (S, 2);
            Put (S, "(if Raw = 0 then " & Special_Default (Rec.Field_Type) &
                   " else " & "Cast (Raw));");
            Decrease_Indent (S, 2);

         else
            Put (S, " Cast (Raw);");
         end if;

         Put (S, LF);

         Decrease_Indent (S, 3);
         Put (S, "begin" & LF);
         Increase_Indent (S, 3);

         Put (S, "--  pragma Debug (Validate_Node_And_Offset (NN, Slot_Off));" & LF);
         --  Comment out the validation, because it's too slow, and because the
         --  relevant routines in Atree are not visible.

         if Rec.Pre.all /= "" then
            Put (S, "pragma Assert (" & Rec.Pre.all & ");" & LF);
         end if;

         if Rec.Pre_Get.all /= "" then
            Put (S, "pragma Assert (" & Rec.Pre_Get.all & ");" & LF);
         end if;

         Put_Get_Set_Incr (S, F, "Get");
         Put (S, "return Val;" & LF);
         Decrease_Indent (S, 3);
         Put (S, "end " & Image (F) & ";" & LF & LF);
      end Put_Getter_Body;

      ---------------------
      -- Put_Setter_Spec --
      ---------------------

      procedure Put_Setter_Spec (S : in out Sink; F : Field_Enum) is
         Rec    : Field_Info renames Field_Table (F).all;
         Default : constant String :=
           (if Rec.Field_Type = Flag then " := True" else "");
      begin
         Put (S, "procedure Set_" & Image (F));
         Put (S, " (N : " & N_Type (F) & "; Val : " &
              Get_Set_Id_Image (Rec.Field_Type) & Default & ")");
      end Put_Setter_Spec;

      ---------------------
      -- Put_Setter_Decl --
      ---------------------

      procedure Put_Setter_Decl (S : in out Sink; F : Field_Enum) is
      begin
         Put_Setter_Spec (S, F);
         Put (S, " with " & Inline);
         Increase_Indent (S, 2);
         Put_Precondition (S, F);
         Decrease_Indent (S, 2);
         Put (S, ";" & LF);
      end Put_Setter_Decl;

      ---------------------
      -- Put_Setter_Body --
      ---------------------

      procedure Put_Setter_Body (S : in out Sink; F : Field_Enum) is
         Rec : Field_Info renames Field_Table (F).all;
         F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type);

         --  If Type_Only was specified in the call to Create_Semantic_Field,
         --  then we assert that the node is a base type. We cannot assert that
         --  it is an implementation base type or a root type.

         Type_Only_Assertion : constant String :=
           (case Rec.Type_Only is
              when No_Type_Only => "",
              when Base_Type_Only | Impl_Base_Type_Only | Root_Type_Only =>
                "Is_Base_Type (N)");
      begin
         Put_Setter_Spec (S, F);
         Put_Getter_Setter_Locals (S, F, Get => False);

         Put (S, "Raw : constant Field_Size_" & Image (F_Size) & "_Bit := Cast (Val);" & LF);

         Decrease_Indent (S, 3);
         Put (S, "begin" & LF);
         Increase_Indent (S, 3);

         Put (S, "--  pragma Debug (Validate_Node_And_Offset_Write (N, Slot_Off));" & LF);
         --  Comment out the validation, because it's too slow, and because the
         --  relevant routines in Atree are not visible.

         if Rec.Pre.all /= "" then
            Put (S, "pragma Assert (" & Rec.Pre.all & ");" & LF);
         end if;

         if Rec.Pre_Set.all /= "" then
            Put (S, "pragma Assert (" & Rec.Pre_Set.all & ");" & LF);
         end if;

         if Type_Only_Assertion /= "" then
            Put (S, "pragma Assert (" & Type_Only_Assertion & ");" & LF);
         end if;

         if Setter_Needs_Parent (F) then
            declare
               Err : constant String :=
                 (if Rec.Field_Type = List_Id then "Error_List" else "Error");
            begin
               Put (S, "if Present (Val) and then Val /= " & Err & " then" & LF);
               Increase_Indent (S, 3);
               Put (S, "pragma Warnings (Off, ""actuals for this call may be in wrong order"");" & LF);
               Put (S, "Set_Parent (Val, N);" & LF);
               Put (S, "pragma Warnings (On, ""actuals for this call may be in wrong order"");" & LF);
               Decrease_Indent (S, 3);
               Put (S, "end if;" & LF & LF);
            end;
         end if;

         if Field_Size (Rec.Field_Type) /= SS then
            Put (S, "S := (S and not Shift_Left (Mask, V)) or Shift_Left (Slot (Raw), V);" & LF);

         else
            Put (S, "S := Slot (Raw);" & LF);
         end if;

         Put_Get_Set_Incr (S, F, "Set");
         Decrease_Indent (S, 3);
         Put (S, "end Set_" & Image (F) & ";" & LF & LF);
      end Put_Setter_Body;

      --------------------
      -- Put_Subp_Decls --
      --------------------

      procedure Put_Subp_Decls (S : in out Sink; Root : Root_Type) is
         --  Note that there are several fields that are defined for both nodes
         --  and entities, such as Nkind. These are allocated slots in both,
         --  but here we only put out getters and setters in Sinfo.Nodes, not
         --  Einfo.Entities.

      begin
         Put (S, "--  Getters and setters for fields" & LF);

         for F in First_Field (Root) .. Last_Field (Root) loop
            --  Nkind/Ekind getter is already done (see Put_Type_And_Subtypes),
            --  and there is no setter for these.

            if F = Nkind then
               Put (S, LF & "--  Nkind getter is above" & LF);

            elsif F = Ekind then
               Put (S, LF & "--  Ekind getter is above" & LF);

            else
               Put_Getter_Decl (S, F);
               Put_Setter_Decl (S, F);
            end if;

            Put (S, LF);
         end loop;
      end Put_Subp_Decls;

      ---------------------
      -- Put_Subp_Bodies --
      ---------------------

      procedure Put_Subp_Bodies (S : in out Sink; Root : Root_Type) is
      begin
         Put (S, LF & "--  Getters and setters for fields" & LF & LF);

         for F in First_Field (Root) .. Last_Field (Root) loop
            Put_Getter_Body (S, F);

            if F not in Nkind | Ekind then
               Put_Setter_Body (S, F);
            end if;
         end loop;
      end Put_Subp_Bodies;

      --------------------------
      -- Put_Traversed_Fields --
      --------------------------

      procedure Put_Traversed_Fields (S : in out Sink) is

         function Is_Traversed_Field
           (T : Concrete_Node; F : Field_Enum) return Boolean;
         --  True if F is a field that should be traversed by Traverse_Func. In
         --  particular, True if F is a syntactic field of T, and is of a
         --  Node_Id or List_Id type.

         function Init_Max_Traversed_Fields return Field_Offset;
         --  Compute the maximum number of syntactic fields that are of type
         --  Node_Id or List_Id over all node types.

         procedure Put_Aggregate (T : Node_Or_Entity_Type);
         --  Print out the subaggregate for one type

         function Is_Traversed_Field
           (T : Concrete_Node; F : Field_Enum) return Boolean is
         begin
            return Syntactic (T) (F)
              and then Field_Table (F).Field_Type in Traversed_Field_Type;
         end Is_Traversed_Field;

         First_Time : Boolean := True;

         procedure Put_Aggregate (T : Node_Or_Entity_Type) is
            Left_Opnd_Skipped : Boolean := False;
         begin
            if T in Concrete_Node then
               if First_Time then
                  First_Time := False;
               else
                  Put (S, "," & LF);
               end if;

               Put (S, Image (T) & " => (");
               Increase_Indent (S, 2);

               for FI in 1 .. Last_Index (Type_Table (T).Fields) loop
                  declare
                     F : constant Field_Enum := Type_Table (T).Fields (FI);

                  begin
                     if Is_Traversed_Field (T, F) then
                        if F = Left_Opnd then
                           Left_Opnd_Skipped := True; -- see comment below

                        else
                           Put (S, Image (Field_Table (F).Offset) & ", ");
                        end if;
                     end if;
                  end;
               end loop;

               --  We always put the Left_Opnd field of N_Op_Concat last. See
               --  comments in Atree.Traverse_Func for the reason. We might as
               --  well do that for all Left_Opnd fields; the old version did
               --  that.

               if Left_Opnd_Skipped then
                  Put (S, Image (Field_Table (Left_Opnd).Offset) & ", ");
               end if;

               Put (S, "others => No_Field_Offset");

               Decrease_Indent (S, 2);
               Put (S, ")");
            end if;
         end Put_Aggregate;

         function Init_Max_Traversed_Fields return Field_Offset is
            Result : Field_Offset := 0;
         begin
            for T in Concrete_Node loop
               declare
                  Num_Traversed_Fields : Field_Offset := 0; -- in type T

               begin
                  for FI in 1 .. Last_Index (Type_Table (T).Fields) loop
                     declare
                        F : constant Field_Enum := Type_Table (T).Fields (FI);

                     begin
                        if Is_Traversed_Field (T, F) then
                           Num_Traversed_Fields := Num_Traversed_Fields + 1;
                        end if;
                     end;
                  end loop;

                  if Num_Traversed_Fields > Result then
                     Result := Num_Traversed_Fields;
                  end if;
               end;
            end loop;

            return Result;
         end Init_Max_Traversed_Fields;

         Max_Traversed_Fields : constant Field_Offset :=
           Init_Max_Traversed_Fields;

      begin
         Put (S, "--  Table of fields that should be traversed by Traverse subprograms." & LF);
         Put (S, "--  Each entry is an array of offsets in slots of fields to be" & LF);
         Put (S, "--  traversed, terminated by a sentinel equal to No_Field_Offset." & LF & LF);

         Put (S, "subtype Traversed_Offset_Array is Offset_Array (0 .. " &
              Image (Max_Traversed_Fields - 1) & " + 1);" & LF);
         Put (S, "Traversed_Fields : constant array (Node_Kind) of Traversed_Offset_Array :=" & LF);
         --  One extra for the sentinel

         Increase_Indent (S, 2);
         Put (S, "(");
         Increase_Indent (S, 1);
         Iterate_Types (Node_Kind, Pre => Put_Aggregate'Access);
         Decrease_Indent (S, 1);
         Put (S, ");" & LF & LF);
         Decrease_Indent (S, 2);
      end Put_Traversed_Fields;

      ----------------
      -- Put_Tables --
      ----------------

      procedure Put_Tables (S : in out Sink; Root : Root_Type) is

         First_Time : Boolean := True;

         procedure Put_Size (T : Node_Or_Entity_Type);
         procedure Put_Size (T : Node_Or_Entity_Type) is
         begin
            if T in Concrete_Type then
               if First_Time then
                  First_Time := False;
               else
                  Put (S, "," & LF);
               end if;

               Put (S, Image (T) & " => " & Image (Type_Size_In_Slots (T)));
            end if;
         end Put_Size;

         procedure Put_Field_Array (T : Concrete_Type);

         procedure Put_Field_Array (T : Concrete_Type) is
            First_Time : Boolean := True;
         begin
            for F in First_Field (Root) .. Last_Field (Root) loop
               if Fields_Per_Node (T) (F) then
                  if First_Time then
                     First_Time := False;
                  else
                     Put (S, "," & LF);
                  end if;

                  Put (S, F_Image (F));
               end if;
            end loop;
         end Put_Field_Array;

         Field_Enum_Type_Name : constant String :=
           (case Root is
              when Node_Kind => "Node_Field",
              when others => "Entity_Field");  -- Entity_Kind

      begin
         Put (S, "--  Table of sizes in " & SSS & "-bit slots for given " &
              Image (Root) & ", for use by Atree:" & LF);

         case Root is
            when Node_Kind =>
               Put (S, LF & "Min_Node_Size : constant Field_Offset := " &
                    Image (Min_Node_Size) & ";" & LF);
               Put (S, "Max_Node_Size : constant Field_Offset := " &
                    Image (Max_Node_Size) & ";" & LF & LF);

            when Entity_Kind =>
               Put (S, LF & "Min_Entity_Size : constant Field_Offset := " &
                    Image (Min_Entity_Size) & ";" & LF);
               Put (S, "Max_Entity_Size : constant Field_Offset := " &
                    Image (Max_Entity_Size) & ";" & LF & LF);
            when others => raise Program_Error;
         end case;

         Put (S, "Size : constant array (" & Image (Root) &
              ") of Field_Offset :=" & LF);
         Increase_Indent (S, 2);
         Put (S, "(");
         Increase_Indent (S, 1);

         Iterate_Types (Root, Pre => Put_Size'Access);

         Decrease_Indent (S, 1);
         Put (S, "); -- Size" & LF);
         Decrease_Indent (S, 2);

         if Root = Node_Kind then
            declare
               type Node_Dummy is array (Node_Field) of Boolean;
               type Entity_Dummy is array (Entity_Field) of Boolean;
               Num_Fields : constant Root_Int :=
                 Node_Dummy'Length + Entity_Dummy'Length;
               First_Time : Boolean := True;
            begin
               Put (S, LF & "--  Enumeration of all " & Image (Num_Fields)
                    & " fields:" & LF & LF);

               Put (S, "type Node_Or_Entity_Field is" & LF);
               Increase_Indent (S, 2);
               Put (S, "(");
               Increase_Indent (S, 1);

               for F in Node_Field loop
                  if First_Time then
                     First_Time := False;
                  else
                     Put (S, "," & LF);
                  end if;

                  Put (S, F_Image (F));
               end loop;

               for F in Entity_Field loop
                  Put (S, "," & LF);
                  Put (S, F_Image (F));
               end loop;

               Decrease_Indent (S, 1);
               Put (S, "); -- Node_Or_Entity_Field" & LF);
               Decrease_Indent (S, 2);
            end;
         end if;

         Put (S, LF & "subtype " & Field_Enum_Type_Name & " is" & LF);
         Increase_Indent (S, 2);
         Put (S, "Node_Or_Entity_Field range " & F_Image (First_Field (Root)) &
                " .. " & F_Image (Last_Field (Root)) & ";" & LF);
         Decrease_Indent (S, 2);

         Put (S, LF & "type " & Field_Enum_Type_Name & "_Index is new Pos;" & LF);
         Put (S, "type " & Field_Enum_Type_Name & "_Array is array (" &
              Field_Enum_Type_Name & "_Index range <>) of " &
              Field_Enum_Type_Name & ";" & LF);
         Put (S, "type " & Field_Enum_Type_Name &
              "_Array_Ref is access constant " & Field_Enum_Type_Name &
              "_Array;" & LF);
         Put (S, "subtype A is " & Field_Enum_Type_Name & "_Array;" & LF);
         --  Short name to make allocators below more readable

         declare
            First_Time : Boolean := True;

            procedure Do_One_Type (T : Node_Or_Entity_Type);
            procedure Do_One_Type (T : Node_Or_Entity_Type) is
            begin
               if T in Concrete_Type then
                  if First_Time then
                     First_Time := False;
                  else
                     Put (S, "," & LF);
                  end if;

                  Put (S, Image (T) & " =>" & LF);
                  Increase_Indent (S, 2);
                  Put (S, "new A'(");
                  Increase_Indent (S, 6);
                  Increase_Indent (S, 1);

                  Put_Field_Array (T);

                  Decrease_Indent (S, 1);
                  Put (S, ")");
                  Decrease_Indent (S, 6);
                  Decrease_Indent (S, 2);
               end if;
            end Do_One_Type;
         begin
            Put (S, LF & "--  Table mapping " & Image (Root) &
                 "s to the sequence of fields that exist in that " &
                 Image (Root) & ":" & LF & LF);

            Put (S, Field_Enum_Type_Name & "_Table : constant array (" &
                 Image (Root) & ") of " & Field_Enum_Type_Name &
                 "_Array_Ref :=" & LF);

            Increase_Indent (S, 2);
            Put (S, "(");
            Increase_Indent (S, 1);

            Iterate_Types (Root, Pre => Do_One_Type'Access);

            Decrease_Indent (S, 1);
            Put (S, "); -- " & Field_Enum_Type_Name & "_Table" & LF);
            Decrease_Indent (S, 2);
         end;

         if Root = Node_Kind then
            declare
               First_Time : Boolean := True;
               FS, FB, LB : Bit_Offset;
               --  Field size in bits, first bit, and last bit for the previous
               --  time around the loop. Used to print a comment after ",".

               procedure One_Comp (F : Field_Enum);

               procedure One_Comp (F : Field_Enum) is
                  pragma Annotate (Codepeer, Modified, Field_Table);
                  Offset : constant Field_Offset :=  Field_Table (F).Offset;
               begin
                  if First_Time then
                     First_Time := False;
                  else
                     Put (S, ",");

                     --  Print comment showing field's bits, except for 1-bit
                     --  fields.

                     if FS /= 1 then
                        Put (S, " -- *" & Image (FS) & " = bits " &
                               Image (FB) & ".." & Image (LB));
                     end if;

                     Put (S, LF);
                  end if;

                  Put (S, F_Image (F) & " => (" &
                       Image (Field_Table (F).Field_Type) & "_Field, " &
                       Image (Offset) & ")");

                  FS := Field_Size (F);
                  FB := First_Bit (F, Offset);
                  LB := Last_Bit (F, Offset);
               end One_Comp;

            begin
               Put (S, LF & "--  Table mapping fields to kind and offset:" & LF & LF);

               Put (S, "Field_Descriptors : constant array (" &
                    "Node_Or_Entity_Field) of Field_Descriptor :=" & LF);

               Increase_Indent (S, 2);
               Put (S, "(");
               Increase_Indent (S, 1);

               for F in Node_Field loop
                  One_Comp (F);
               end loop;

               for F in Entity_Field loop
                  One_Comp (F);
               end loop;

               Decrease_Indent (S, 1);
               Put (S, "); -- Field_Descriptors" & LF);
               Decrease_Indent (S, 2);
            end;
         end if;

      end Put_Tables;

      ----------------
      -- Put_Seinfo --
      ----------------

      procedure Put_Seinfo is
         S : Sink;
      begin
         Create_File (S, "seinfo.ads");
         Put (S, "with Types; use Types;" & LF);
         Put (S, LF & "package Seinfo is" & LF & LF);
         Increase_Indent (S, 3);

         Put (S, "--  This package is automatically generated." & LF & LF);

         Put (S, "--  Common declarations visible in both Sinfo.Nodes and Einfo.Entities." & LF);

         Put (S, LF & "type Field_Kind is" & LF);
         Increase_Indent (S, 2);
         Put (S, "(");
         Increase_Indent (S, 1);

         declare
            First_Time : Boolean := True;
         begin
            for T in Special_Type loop
               if First_Time then
                  First_Time := False;
               else
                  Put (S, "," & LF);
               end if;

               Put (S, Image (T) & "_Field");
            end loop;
         end;

         Decrease_Indent (S, 1);
         Decrease_Indent (S, 2);
         Put (S, ");" & LF);

         Put (S, LF & "Field_Size : constant array (Field_Kind) of Field_Size_In_Bits :=" & LF);
         Increase_Indent (S, 2);
         Put (S, "(");
         Increase_Indent (S, 1);

         declare
            First_Time : Boolean := True;
         begin
            for T in Special_Type loop
               if First_Time then
                  First_Time := False;
               else
                  Put (S, "," & LF);
               end if;

               Put (S, Image (T) & "_Field => " & Image (Field_Size (T)));
            end loop;
         end;

         Decrease_Indent (S, 1);
         Decrease_Indent (S, 2);
         Put (S, ");" & LF & LF);

         Put (S, "type Field_Descriptor is record" & LF);
         Increase_Indent (S, 3);
         Put (S, "Kind : Field_Kind;" & LF);
         Put (S, "Offset : Field_Offset;" & LF);
         Decrease_Indent (S, 3);
         Put (S, "end record;" & LF & LF);

         --  Print out the node header types. Note that the Offset field is of
         --  the base type, because we are using zero-origin addressing in
         --  Atree.

         Put (S, "N_Head : constant Field_Offset := " & N_Head & ";" & LF & LF);

         Put (S, "Atree_Statistics_Enabled : constant Boolean := " &
                Capitalize (Boolean'Image (Statistics_Enabled)) & ";" & LF);

         Decrease_Indent (S, 3);
         Put (S, LF & "end Seinfo;" & LF);
      end Put_Seinfo;

      ---------------
      -- Put_Nodes --
      ---------------

      procedure Put_Nodes is
         S : Sink;
         B : Sink;

      begin
         Create_File (S, "sinfo-nodes.ads");
         Create_File (B, "sinfo-nodes.adb");
         Put (S, "with Seinfo; use Seinfo;" & LF);
         Put (S, "pragma Warnings (Off);" & LF);
         --  With's included in case they are needed; so we don't have to keep
         --  switching back and forth.
         Put (S, "with Output; use Output;" & LF);
         Put (S, "pragma Warnings (On);" & LF);

         Put (S, LF & "package Sinfo.Nodes is" & LF & LF);
         Increase_Indent (S, 3);

         Put (S, "--  This package is automatically generated." & LF & LF);

         Put_Type_Hierarchy (S, Node_Kind);

         Put_Type_And_Subtypes (S, Node_Kind);

         Put (S, "pragma Assert (Node_Kind'Pos (N_Unused_At_Start) = 0);" & LF & LF);
         Put (S, "pragma Assert (Node_Kind'Last = N_Unused_At_End);" & LF & LF);

         Put_Subp_Decls (S, Node_Kind);

         Put_Traversed_Fields (S);

         Put_Tables (S, Node_Kind);

         Decrease_Indent (S, 3);
         Put (S, LF & "end Sinfo.Nodes;" & LF);

         Put (B, "with Unchecked_Conversion;" & LF);
         Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;" & LF);
         Put (B, "with Nlists; use Nlists;" & LF);
         Put (B, "pragma Warnings (Off);" & LF);
         Put (B, "with Einfo.Utils; use Einfo.Utils;" & LF);
         Put (B, "with Sinfo.Utils; use Sinfo.Utils;" & LF);
         Put (B, "pragma Warnings (On);" & LF);

         Put (B, LF & "package body Sinfo.Nodes is" & LF & LF);
         Increase_Indent (B, 3);

         Put (B, "--  This package is automatically generated." & LF & LF);

         Put (B, "pragma Style_Checks (""M200"");" & LF);

         for T in Special_Type loop
            if Node_Field_Types_Used (T) then
               Put_Casts (B, T);
            end if;
         end loop;

         Put_Subp_Bodies (B, Node_Kind);

         Decrease_Indent (B, 3);
         Put (B, "end Sinfo.Nodes;" & LF);

      end Put_Nodes;

      ------------------
      -- Put_Entities --
      ------------------

      procedure Put_Entities is
         S : Sink;
         B : Sink;
      begin
         Create_File (S, "einfo-entities.ads");
         Create_File (B, "einfo-entities.adb");
         Put (S, "with Sinfo.Nodes; use Sinfo.Nodes;" & LF);

         Put (S, LF & "package Einfo.Entities is" & LF & LF);
         Increase_Indent (S, 3);

         Put (S, "--  This package is automatically generated." & LF & LF);

         Put_Type_Hierarchy (S, Entity_Kind);

         Put_Type_And_Subtypes (S, Entity_Kind);

         Put_Subp_Decls (S, Entity_Kind);

         Put_Tables (S, Entity_Kind);

         Decrease_Indent (S, 3);
         Put (S, LF & "end Einfo.Entities;" & LF);

         Put (B, "with Unchecked_Conversion;" & LF);
         Put (B, "with Atree; use Atree; use Atree.Atree_Private_Part;" & LF);
         Put (B, "with Einfo.Utils; use Einfo.Utils;" & LF);
         --  This forms a cycle between packages (via bodies, which is OK)

         Put (B, LF & "package body Einfo.Entities is" & LF & LF);
         Increase_Indent (B, 3);

         Put (B, "--  This package is automatically generated." & LF & LF);

         Put (B, "pragma Style_Checks (""M200"");" & LF);

         for T in Special_Type loop
            if Entity_Field_Types_Used (T) then
               Put_Casts (B, T);
            end if;
         end loop;

         Put_Subp_Bodies (B, Entity_Kind);

         Decrease_Indent (B, 3);
         Put (B, "end Einfo.Entities;" & LF);

      end Put_Entities;

      -------------------
      -- Put_Make_Spec --
      -------------------

      procedure Put_Make_Spec
        (S : in out Sink; Root : Root_Type; T : Concrete_Type)
      is
      begin
         Put (S, "function Make_" & Image_Sans_N (T) & "" & LF);
         Increase_Indent (S, 2);
         Put (S, "(Sloc : Source_Ptr");
         Increase_Indent (S, 1);

         for F of Type_Table (T).Fields loop
            pragma Assert (Fields_Per_Node (T) (F));

            if Syntactic (T) (F) then
               declare
                  Typ : constant String :=
                    (if Field_Table (F).Field_Type = Flag then "Boolean"
                     else Image (Field_Table (F).Field_Type));

                  --  All Flag fields have a default, which is False by
                  --  default.

                  Default : constant String :=
                    (if Field_Table (F).Default_Value = No_Default then
                     (if Field_Table (F).Field_Type = Flag then " := False" else "")
                     else " := " & Value_Image (Field_Table (F).Default_Value));

               begin
                  Put (S, ";" & LF);
                  Put (S, Image (F));
                  Put (S, " : " & Typ & Default);
               end;
            end if;
         end loop;

         Put (S, ")" & LF);
         Put (S, "return " & Node_Or_Entity (Root) & "_Id");
         Decrease_Indent (S, 2);
         Decrease_Indent (S, 1);
      end Put_Make_Spec;

      --------------------
      -- Put_Make_Decls --
      --------------------

      procedure Put_Make_Decls (S : in out Sink; Root : Root_Type) is
      begin
         for T in First_Concrete (Root) .. Last_Concrete (Root) loop
            if T not in N_Unused_At_Start | N_Unused_At_End then
               Put_Make_Spec (S, Root, T);
               Put (S, ";" & LF & "pragma " & Inline & " (Make_" &
                    Image_Sans_N (T) & ");" & LF & LF);
            end if;
         end loop;
      end Put_Make_Decls;

      ---------------------
      -- Put_Make_Bodies --
      ---------------------

      procedure Put_Make_Bodies (S : in out Sink; Root : Root_Type) is
      begin
         for T in First_Concrete (Root) .. Last_Concrete (Root) loop
            if T not in N_Unused_At_Start | N_Unused_At_End then
               Put_Make_Spec (S, Root, T);
               Put (S, LF & "is" & LF);

               Increase_Indent (S, 3);
               Put (S, "N : constant Node_Id :=" & LF);

               if T in Entity_Node then
                  Put (S, "      New_Entity (" & Image (T) & ", Sloc);" & LF);

               else
                  Put (S, "      New_Node (" & Image (T) & ", Sloc);" & LF);
               end if;

               Decrease_Indent (S, 3);

               Put (S, "begin" & LF);

               Increase_Indent (S, 3);
               for F of Type_Table (T).Fields loop
                  pragma Assert (Fields_Per_Node (T) (F));

                  if Syntactic (T) (F) then
                     declare
                        NWidth : constant := 28;
                        --  This constant comes from the old Xnmake, which wraps
                        --  the Set_... call if the field name is that long or
                        --  longer.

                        F_Name : constant String := Image (F);

                     begin
                        if F_Name'Length < NWidth then
                           Put (S, "Set_" & F_Name & " (N, " & F_Name & ");" & LF);

                        --  Wrap the line

                        else
                           Put (S, "Set_" & F_Name & "" & LF);
                           Increase_Indent (S, 2);
                           Put (S, "(N, " & F_Name & ");" & LF);
                           Decrease_Indent (S, 2);
                        end if;
                     end;
                  end if;
               end loop;

               if Is_Descendant (N_Op, T) then
                  --  Special cases for N_Op nodes: fill in the Chars and Entity
                  --  fields even though they were not passed in.

                  declare
                     Op : constant String := Image_Sans_N (T);
                     --  This will be something like "Op_And" or "Op_Add"

                     Op_Name_With_Op : constant String :=
                       (if T = N_Op_Plus then "Op_Add"
                        elsif T = N_Op_Minus then "Op_Subtract"
                        else Op);
                     --  Special cases for unary operators that have the same name
                     --  as a binary operator; we use the binary operator name in
                     --  that case.

                     Slid : constant String (1 .. Op_Name_With_Op'Length) :=
                       Op_Name_With_Op;
                     pragma Assert (Slid (1 .. 3) = "Op_");

                     Op_Name : constant String :=
                       (if T in N_Op_Rotate_Left |
                          N_Op_Rotate_Right |
                          N_Op_Shift_Left |
                          N_Op_Shift_Right |
                          N_Op_Shift_Right_Arithmetic
                        then Slid (4 .. Slid'Last)
                        else Slid);
                     --  Special cases for shifts and rotates; the node kind has
                     --  "Op_", but the Name_Id constant does not.

                  begin
                     Put (S, "Set_Chars (N, Name_" & Op_Name & ");" & LF);
                     Put (S, "Set_Entity (N, Standard_" & Op & ");" & LF);
                  end;
               end if;

               if Type_Table (T).Nmake_Assert.all /= "" then
                  Put (S, "pragma Assert (" &
                           Type_Table (T).Nmake_Assert.all & ");" & LF);
               end if;

               Put (S, "return N;" & LF);
               Decrease_Indent (S, 3);

               Put (S, "end Make_" & Image_Sans_N (T) & ";" & LF & LF);
            end if;
         end loop;
      end Put_Make_Bodies;

      ---------------
      -- Put_Nmake --
      ---------------

      --  Documentation for the Nmake package, generated by Put_Nmake below.

      --  The Nmake package contains a set of routines used to construct tree
      --  nodes using a functional style. There is one routine for each node
      --  type defined in Gen_IL.Gen.Gen_Nodes with the general interface:

      --    function Make_xxx (Sloc : Source_Ptr,
      --                       Field_Name_1 : Field_Name_1_Type [:= default]
      --                       Field_Name_2 : Field_Name_2_Type [:= default]
      --                       ...)
      --    return Node_Id

      --  Only syntactic fields are included.

      --  Default values are provided as specified in Gen_Nodes, except that if
      --  no default is specified for a flag field, it has a default of False.

      --  Warning: since calls to Make_xxx routines are normal function calls, the
      --  arguments can be evaluated in any order. This means that at most one such
      --  argument can have side effects (e.g. be a call to a parse routine).

      procedure Put_Nmake is
         S : Sink;
         B : Sink;

      begin
         Create_File (S, "nmake.ads");
         Create_File (B, "nmake.adb");
         Put (S, "with Namet;  use Namet;" & LF);
         Put (S, "with Nlists; use Nlists;" & LF);
         Put (S, "with Types;  use Types;" & LF);
         Put (S, "with Uintp;  use Uintp;" & LF);
         Put (S, "with Urealp; use Urealp;" & LF);

         Put (S, LF & "package Nmake is" & LF & LF);
         Increase_Indent (S, 3);

         Put (S, "--  This package is automatically generated." & LF & LF);
         Put (S, "--  See Put_Nmake in gen_il-gen.adb for documentation." & LF & LF);

         Put_Make_Decls (S, Node_Kind);

         Decrease_Indent (S, 3);
         Put (S, "end Nmake;" & LF);

         Put (B, "with Atree;  use Atree;" & LF);
         Put (B, "with Sinfo.Nodes; use Sinfo.Nodes;" & LF);
         Put (B, "with Sinfo.Utils; use Sinfo.Utils;" & LF);
         Put (B, "with Snames; use Snames;" & LF);
         Put (B, "with Stand;  use Stand;" & LF);

         Put (B, LF & "package body Nmake is" & LF & LF);
         Increase_Indent (B, 3);

         Put (B, "--  This package is automatically generated." & LF & LF);
         Put (B, "pragma Style_Checks (""M200"");" & LF);

         Put_Make_Bodies (B, Node_Kind);

         Decrease_Indent (B, 3);
         Put (B, "end Nmake;" & LF);
      end Put_Nmake;

      -----------------------
      -- Put_Seinfo_Tables --
      -----------------------

      procedure Put_Seinfo_Tables is
         S : Sink;
         B : Sink;

         Type_Layout : Concrete_Type_Layout_Array;

         function Get_Last_Bit
           (T : Concrete_Type; F : Opt_Field_Enum; First_Bit : Bit_Offset)
            return Bit_Offset;
         function First_Bit_Image (First_Bit : Bit_Offset) return String;
         function Last_Bit_Image (Last_Bit : Bit_Offset) return String;

         procedure Put_Field_List (Bit : Bit_Offset);
         --  Print out the list of fields that are allocated (in part, for
         --  fields bigger than one bit) at the given bit offset. This allows
         --  us to see which fields are overlaid with each other, which should
         --  only happen if the sets of types with those fields are disjoint.

         function Get_Last_Bit
           (T : Concrete_Type; F : Opt_Field_Enum; First_Bit : Bit_Offset)
            return Bit_Offset is
         begin
            return Result : Bit_Offset do
               if F = No_Field then
                  --  We don't have a field size for No_Field, so just look at
                  --  the bits up to the next slot boundary.

                  Result := First_Bit;

                  while (Result + 1) mod SS /= 0
                    and then Type_Layout (T) (Result + 1) = No_Field
                  loop
                     Result := Result + 1;
                  end loop;

               else
                  Result := First_Bit + Field_Size (F) - 1;
               end if;
            end return;
         end Get_Last_Bit;

         function First_Bit_Image (First_Bit : Bit_Offset) return String is
            W : constant Bit_Offset := First_Bit / SS;
            B : constant Bit_Offset := First_Bit mod SS;
            pragma Assert (W * SS + B = First_Bit);
         begin
            return
              Image (W) & "*" & SSS & (if B = 0 then "" else " + " & Image (B));
         end First_Bit_Image;

         function Last_Bit_Image (Last_Bit : Bit_Offset) return String is
            W : constant Bit_Offset := (Last_Bit + 1) / SS;
         begin
            if W * SS - 1 = Last_Bit then
               return Image (W) & "*" & SSS & " - 1";
            else
               return First_Bit_Image (Last_Bit);
            end if;
         end Last_Bit_Image;

         function Image_Or_Waste (F : Opt_Field_Enum) return String is
           (if F = No_Field then "Wasted_Bits" else Image (F));

         Num_Wasted_Bits : Bit_Offset'Base := 0;

         Type_Layout_Size : Bit_Offset'Base := Type_Layout'Size;
         --  Total size of Type_Layout, including the Field_Arrays its
         --  components point to.

         procedure Put_Field_List (Bit : Bit_Offset) is
            First_Time : Boolean := True;
         begin
            for F in Field_Enum loop
               if F /= Between_Node_And_Entity_Fields
                 and then Bit in First_Bit (F, Field_Table (F).Offset)
                               .. Last_Bit (F, Field_Table (F).Offset)
               then
                  if First_Time then
                     First_Time := False;
                  else
                     Put (B, "," & LF);
                  end if;

                  Put (B, Image (F));
               end if;
            end loop;
         end Put_Field_List;

      begin -- Put_Seinfo_Tables
         Create_File (S, "seinfo_tables.ads");
         Create_File (B, "seinfo_tables.adb");

         for T in Concrete_Type loop
            Type_Layout (T) := new Field_Array'
              (0 .. Type_Bit_Size_Aligned (T) - 1 => No_Field);
            Type_Layout_Size := Type_Layout_Size + Type_Layout (T).all'Size;

            for F in Field_Enum loop
               if Fields_Per_Node (T) (F) then
                  declare
                     Off : constant Field_Offset := Field_Table (F).Offset;
                     subtype Bit_Range is Bit_Offset
                       range First_Bit (F, Off) .. Last_Bit (F, Off);
                  begin
                     pragma Assert
                       (Type_Layout (T) (Bit_Range) = (Bit_Range => No_Field));
                     Type_Layout (T) (Bit_Range) := (others => F);
                  end;
               end if;
            end loop;
         end loop;

         for T in Concrete_Type loop
            for B in 0 .. Type_Bit_Size_Aligned (T) - 1 loop
               if Type_Layout (T) (B) = No_Field then
                  Num_Wasted_Bits := Num_Wasted_Bits + 1;
               end if;
            end loop;
         end loop;

         Put (S, LF & "package Seinfo_Tables is" & LF & LF);
         Increase_Indent (S, 3);

         Put (S, "--  This package is automatically generated." & LF & LF);

         Put (S, "--  This package is not used by the compiler." & LF);
         Put (S, "--  The body contains tables that are intended to be used by humans to" & LF);
         Put (S, "--  help understand the layout of various data structures." & LF);
         Put (S, "--  Search for ""--"" to find major sections of code." & LF & LF);

         Put (S, "pragma Elaborate_Body;" & LF);

         Decrease_Indent (S, 3);
         Put (S, LF & "end Seinfo_Tables;" & LF);

         Put (B, "with Gen_IL.Types;  use Gen_IL.Types;" & LF);
         Put (B, "with Gen_IL.Fields; use Gen_IL.Fields;" & LF);
         Put (B, "with Gen_IL.Internals;  use Gen_IL.Internals;" & LF);

         Put (B, LF & "package body Seinfo_Tables is" & LF & LF);
         Increase_Indent (B, 3);

         Put (B, "--  This package is automatically generated." & LF & LF);

         Put (B, "Num_Wasted_Bits : Bit_Offset'Base := " & Image (Num_Wasted_Bits) &
              " with Unreferenced;" & LF);

         Put (B, LF & "Wasted_Bits : constant Opt_Field_Enum := No_Field;" & LF);

         Put (B, LF & "--  Table showing the layout of each Node_Or_Entity_Type. For each" & LF);
         Put (B, "--  concrete type, we show the bits used by each field. Each field" & LF);
         Put (B, "--  uses the same bit range in all types. This table is not used by" & LF);
         Put (B, "--  the compiler; it is for information only." & LF & LF);

         Put (B, "--  Wasted_Bits are unused bits between fields, and padding at the end" & LF);
         Put (B, "--  to round up to a multiple of the slot size." & LF);

         Put (B, LF & "--  Type_Layout is " & Image (Type_Layout_Size / 8) & " bytes." & LF);

         Put (B, LF & "pragma Style_Checks (Off);" & LF);
         Put (B, "Type_Layout : constant Concrete_Type_Layout_Array := " & LF);
         Increase_Indent (B, 2);
         Put (B, "--  Concrete node types:" & LF);
         Put (B, "(");
         Increase_Indent (B, 1);

         declare
            First_Time : Boolean := True;

         begin
            for T in Concrete_Type loop
               if First_Time then
                  First_Time := False;
               else
                  Put (B, "," & LF & LF);
               end if;

               if T = Concrete_Entity'First then
                  Put (B, "--  Concrete entity types:" & LF & LF);
               end if;

               Put (B, Image (T) & " => new Field_Array'" & LF);

               Increase_Indent (B, 2);
               Put (B, "(");
               Increase_Indent (B, 1);

               declare
                  First_Time : Boolean := True;
                  First_Bit : Bit_Offset := 0;
                  F : Opt_Field_Enum;

                  function Node_Field_Of_Entity return String is
                     (if T in Entity_Type and then F in Node_Field then
                       " -- N" else "");
                  --  A comment to put out for fields of entities that are
                  --  shared with nodes, such as Chars.

               begin
                  while First_Bit < Type_Bit_Size_Aligned (T) loop
                     if First_Time then
                        First_Time := False;
                     else
                        Put (B, "," & Node_Field_Of_Entity & LF);
                     end if;

                     F := Type_Layout (T) (First_Bit);

                     declare
                        Last_Bit : constant Bit_Offset :=
                          Get_Last_Bit (T, F, First_Bit);
                     begin
                        pragma Assert
                          (Type_Layout (T) (First_Bit .. Last_Bit) =
                                           (First_Bit .. Last_Bit => F));

                        if Last_Bit = First_Bit then
                           Put (B, First_Bit_Image (First_Bit) & " => " &
                                Image_Or_Waste (F));
                        else
                           pragma Assert
                             (if F /= No_Field then
                               First_Bit mod Field_Size (F) = 0);
                           Put (B, First_Bit_Image (First_Bit) & " .. " &
                                Last_Bit_Image (Last_Bit) & " => " &
                                Image_Or_Waste (F));
                        end if;

                        First_Bit := Last_Bit + 1;
                     end;
                  end loop;
               end;

               Decrease_Indent (B, 1);
               Put (B, ")");
               Decrease_Indent (B, 2);
            end loop;
         end;

         Decrease_Indent (B, 1);
         Put (B, ") -- Type_Layout" & LF);
         Increase_Indent (B, 6);
         Put (B, "with Export, Convention => Ada;" & LF);
         Decrease_Indent (B, 6);
         Decrease_Indent (B, 2);

         Put (B, LF & "--  Table mapping bit offsets to the set of fields at that offset" & LF & LF);
         Put (B, "Bit_Used : constant Offset_To_Fields_Mapping :=" & LF);

         Increase_Indent (B, 2);
         Put (B, "(");
         Increase_Indent (B, 1);

         declare
            First_Time : Boolean := True;
         begin
            for Bit in 0 .. Bit_Offset'Max
              (Max_Node_Bit_Size, Max_Entity_Bit_Size)
            loop
               if First_Time then
                  First_Time := False;
               else
                  Put (B, "," & LF & LF);
               end if;

               Put (B, First_Bit_Image (Bit) & " => new Field_Array'" & LF);

               --  Use [...] notation here, to get around annoying Ada
               --  limitations on empty and singleton aggregates. This code is
               --  not used in the compiler, so there are no bootstrap issues.

               Increase_Indent (B, 2);
               Put (B, "[");
               Increase_Indent (B, 1);

               Put_Field_List (Bit);

               Decrease_Indent (B, 1);
               Put (B, "]");
               Decrease_Indent (B, 2);
            end loop;
         end;

         Decrease_Indent (B, 1);
         Put (B, "); -- Bit_Used" & LF);
         Decrease_Indent (B, 2);

         Decrease_Indent (B, 3);
         Put (B, LF & "end Seinfo_Tables;" & LF);

      end Put_Seinfo_Tables;

      -----------------------------
      -- Put_C_Type_And_Subtypes --
      -----------------------------

      procedure Put_C_Type_And_Subtypes
        (S : in out Sink; Root : Root_Type) is

         Cur_Pos : Root_Nat := 0;
         --  Current Node_Kind'Pos or Entity_Kind'Pos to be printed

         procedure Put_Enum_Lit (T : Node_Or_Entity_Type);
         --  Print out the #define corresponding to the Ada enumeration literal
         --  for T in Node_Kind and Entity_Kind (i.e. concrete types).
         --  This looks like "#define Some_Kind <pos>", where Some_Kind
         --  is the Node_Kind or Entity_Kind enumeration literal, and
         --  <pos> is Node_Kind'Pos or Entity_Kind'Pos of that literal.

         procedure Put_Kind_Subtype (T : Node_Or_Entity_Type);
         --  Print out the SUBTYPE macro call corresponding to an abstract
         --  type.

         procedure Put_Enum_Lit (T : Node_Or_Entity_Type) is
         begin
            if T in Concrete_Type then
               Put (S, "#define " & Image (T) & " " & Image (Cur_Pos) & LF);
               Cur_Pos := Cur_Pos + 1;
            end if;
         end Put_Enum_Lit;

         procedure Put_Kind_Subtype (T : Node_Or_Entity_Type) is
         begin
            if T in Abstract_Type and then Type_Table (T).Parent /= No_Type then
               Put (S, "SUBTYPE (" & Image (T) & ", " &
                    Image (Type_Table (T).Parent) & "," & LF);
               Increase_Indent (S, 3);
               Put (S, Image (Type_Table (T).First) & "," & LF);
               Put (S, Image (Type_Table (T).Last) & ")" & LF);
               Decrease_Indent (S, 3);
            end if;
         end Put_Kind_Subtype;

      begin
         Put_Union_Membership (S, Root, Only_Prototypes => True);

         Iterate_Types (Root, Pre => Put_Enum_Lit'Access);

         Put (S, "#define Number_" & Node_Or_Entity (Root) & "_Kinds " &
              Image (Cur_Pos) & "" & LF & LF);

         Iterate_Types (Root, Pre => Put_Kind_Subtype'Access);

         Put_Union_Membership (S, Root, Only_Prototypes => False);
      end Put_C_Type_And_Subtypes;

      ------------------
      -- Put_C_Getter --
      ------------------

      procedure Put_C_Getter
        (S : in out Sink; F : Field_Enum)
      is
         Rec : Field_Info renames Field_Table (F).all;

         Off : constant Field_Offset := Rec.Offset;
         F_Size : constant Bit_Offset := Field_Size (Rec.Field_Type);
         F_Per_Slot : constant Field_Offset :=
           SS / Field_Offset (Field_Size (Rec.Field_Type));
         Slot_Off : constant Field_Offset := Off / F_Per_Slot;
         In_NH : constant Boolean := Slot_Off < Num_Header_Slots;

         N : constant String := Node_To_Fetch_From (F);
      begin
         Put (S, "INLINE " & Get_Set_Id_Image (Rec.Field_Type) &
              " " & Image (F) & " (Node_Id N)" & LF);

         Put (S, "{" & LF);
         Increase_Indent (S, 3);
         Put (S, "const Field_Offset Off = " & Image (Rec.Offset) & ";" & LF);
         Put (S, "const Field_Offset F_Size = " & Image (F_Size) & ";" & LF);

         if Field_Size (Rec.Field_Type) /= SS then
            Put (S, "const any_slot Mask = (1 << F_Size) - 1;" & LF);
         end if;

         Put (S, "const Field_Offset F_Per_Slot = Slot_Size / F_Size;" & LF);
         Put (S, "const Field_Offset Slot_Off = Off / F_Per_Slot;" & LF);
         Put (S, LF);
         if In_NH then
            Put (S, "any_slot slot = Node_Offsets_Ptr[" & N & "].Slots[Slot_Off];" & LF);
         else
            Put (S, "any_slot slot = *(Slots_Ptr + Node_Offsets_Ptr[" & N &
                   "].Offset + Slot_Off);" & LF);
         end if;

         if Field_Size (Rec.Field_Type) /= SS then
            Put (S, "unsigned int Raw = (slot >> (Off % F_Per_Slot) * F_Size) & Mask;" & LF);
         else
            Put (S, "unsigned int Raw = slot;" & LF);
         end if;

         Put (S, Get_Set_Id_Image (Rec.Field_Type) & " val = ");

         if Field_Has_Special_Default (Rec.Field_Type) then
            Increase_Indent (S, 2);
            Put (S, "(Raw? Raw : " & Special_Default (Rec.Field_Type) & ")");
            Decrease_Indent (S, 2);

         else
            Put (S, "Raw");
         end if;

         Put (S, ";" & LF);

         Put (S, "return val;" & LF);
         Decrease_Indent (S, 3);
         Put (S, "}" & LF & LF);
      end Put_C_Getter;

      -------------------
      -- Put_C_Getters --
      -------------------

      procedure Put_C_Getters
        (S : in out Sink; Root : Root_Type)
      is
      begin
         Put (S, "// Getters for fields" & LF & LF);

         for F in First_Field (Root) .. Last_Field (Root) loop
            Put_C_Getter (S, F);
         end loop;
      end Put_C_Getters;

      --------------------------
      -- Put_Union_Membership --
      --------------------------

      procedure Put_Union_Membership
        (S : in out Sink; Root : Root_Type; Only_Prototypes : Boolean) is

         procedure Put_Ors (T : Abstract_Type);
         --  Print the "or" (i.e. "||") of tests whether kind is in each child
         --  type.

         procedure Put_Ors (T : Abstract_Type) is
            First_Time : Boolean := True;
         begin
            for Child of Type_Table (T).Children loop
               if First_Time then
                  First_Time := False;
               else
                  Put (S, " ||" & LF);
               end if;

               --  Unions, other abstract types, and concrete types each have
               --  their own way of testing membership in the C++ code.

               if Child in Abstract_Type then
                  if Type_Table (Child).Is_Union then
                     Put (S, "Is_In_" & Image (Child) & " (kind)");

                  else
                     Put (S, "IN (kind, " & Image (Child) & ")");
                  end if;

               else
                  Put (S, "kind == " & Image (Child));
               end if;
            end loop;
         end Put_Ors;

      begin
         if not Only_Prototypes then
            Put (S, LF & "// Membership tests for union types" & LF & LF);
         end if;

         for T in First_Abstract (Root) .. Last_Abstract (Root) loop
            if Type_Table (T) /= null and then Type_Table (T).Is_Union then
               Put (S, "INLINE Boolean" & LF);
               Put (S, "Is_In_" & Image (T) & " (" &
                    Node_Or_Entity (Root) & "_Kind kind)" &
                    (if Only_Prototypes then ";" else "") & LF);

               if not Only_Prototypes then
                  Put (S, "{" & LF);
                  Increase_Indent (S, 3);
                  Put (S, "return" & LF);
                  Increase_Indent (S, 3);
                  Put_Ors (T);
                  Decrease_Indent (S, 3);
                  Decrease_Indent (S, 3);
                  Put (S, ";" & LF & "}" & LF);
               end if;

               Put (S, "" & LF);
            end if;
         end loop;
      end Put_Union_Membership;

      ---------------------
      -- Put_Sinfo_Dot_H --
      ---------------------

      procedure Put_Sinfo_Dot_H is
         S : Sink;

      begin
         Create_File (S, "sinfo.h");
         Put (S, "#ifdef __cplusplus" & LF);
         Put (S, "extern ""C"" {" & LF);
         Put (S, "#endif" & LF & LF);

         Put (S, "typedef Boolean Flag;" & LF & LF);

         Put (S, "#define N_Head " & N_Head & LF);
         Put (S, "" & LF);
         Put (S, "typedef struct Node_Header {" & LF);
         Increase_Indent (S, 2);
         Put (S, "any_slot Slots[N_Head];" & LF);
         Put (S, "Field_Offset Offset;" & LF);
         Decrease_Indent (S, 2);
         Put (S, "} Node_Header;" & LF & LF);

         Put (S, "extern Node_Header *Node_Offsets_Ptr;" & LF);
         Put (S, "extern any_slot *Slots_Ptr;" & LF & LF);

         Put_C_Type_And_Subtypes (S, Node_Kind);

         Put (S, "// Getters corresponding to instantiations of Atree.Get_n_Bit_Field"
                 & LF & LF);

         Put_C_Getters (S, Node_Kind);

         Put (S, "#ifdef __cplusplus" & LF);
         Put (S, "}" & LF);
         Put (S, "#endif" & LF);
      end Put_Sinfo_Dot_H;

      ---------------------
      -- Put_Einfo_Dot_H --
      ---------------------

      procedure Put_Einfo_Dot_H is
         S : Sink;

         procedure Put_Membership_Query_Spec (T : Node_Or_Entity_Type);
         procedure Put_Membership_Query_Defn (T : Node_Or_Entity_Type);
         --  Print out the Is_... function for T that calls the IN macro on the
         --  SUBTYPE.

         procedure Put_Membership_Query_Spec (T : Node_Or_Entity_Type) is
            Im : constant String := Image (T);
            pragma Assert (Im (Im'Last - 4 .. Im'Last) = "_Kind");
            Im2 : constant String := Im (Im'First .. Im'Last - 5);
            Typ : constant String :=
              (if Is_Descendant (Type_Kind, T)
                 and then T /= Type_Kind
               then "_Type"
               else "");
         begin
            pragma Assert (not Type_Table (T).Is_Union);

            Put (S, "INLINE B Is_" & Im2 & Typ & " (E Id)");
         end Put_Membership_Query_Spec;

         procedure Put_Membership_Query_Defn (T : Node_Or_Entity_Type) is
         begin
            if T in Abstract_Type and T not in Root_Type then
               Put_Membership_Query_Spec (T);
               Put (S, "" & LF);
               Increase_Indent (S, 3);
               Put (S, "{ return IN (Ekind (Id), " & Image (T) & "); }" & LF);
               Decrease_Indent (S, 3);
            end if;
         end Put_Membership_Query_Defn;

      begin
         Create_File (S, "einfo.h");
         Put (S, "#ifdef __cplusplus" & LF);
         Put (S, "extern ""C"" {" & LF);
         Put (S, "#endif" & LF & LF);

         Put (S, "typedef Boolean Flag;" & LF & LF);

         Put_C_Type_And_Subtypes (S, Entity_Kind);

         Put_C_Getters (S, Entity_Kind);

         Put (S, "// Abstract type queries" & LF & LF);

         Iterate_Types (Entity_Kind, Pre => Put_Membership_Query_Defn'Access);

         Put (S, LF & "#ifdef __cplusplus" & LF);
         Put (S, "}" & LF);
         Put (S, "#endif" & LF);
      end Put_Einfo_Dot_H;

   begin -- Compile

      Check_Completeness;

      Compute_Ranges (Node_Kind);
      Compute_Ranges (Entity_Kind);
      Compute_Fields_Per_Node;
      Compute_Field_Offsets;
      Compute_Type_Sizes;
      Check_For_Syntactic_Field_Mismatch;

      Verify_Type_Table;

      Node_Field_Types_Used :=
        Field_Types_Used (Node_Field'First, Node_Field'Last);
      Entity_Field_Types_Used :=
        Field_Types_Used (Entity_Field'First, Entity_Field'Last);

      Put_Seinfo;

      Put_Nodes;

      Put_Entities;

      Put_Nmake;

      Put_Seinfo_Tables;

      Put_Sinfo_Dot_H;
      Put_Einfo_Dot_H;

   end Compile;

   --------
   -- Sy --
   --------

   function Sy
     (Field      : Node_Field;
      Field_Type : Type_Enum;
      Default_Value : Field_Default_Value := No_Default;
      Pre, Pre_Get, Pre_Set : String := "") return Field_Sequence is
   begin
      return
        (1 => Create_Syntactic_Field
           (Field, Field_Type, Default_Value, Pre, Pre_Get, Pre_Set));
   end Sy;

   --------
   -- Sm --
   --------

   function Sm
     (Field      : Field_Enum;
      Field_Type : Type_Enum;
      Type_Only  : Type_Only_Enum := No_Type_Only;
      Pre, Pre_Get, Pre_Set : String := "") return Field_Sequence is
   begin
      return (1 => Create_Semantic_Field
                (Field, Field_Type, Type_Only, Pre, Pre_Get, Pre_Set));
   end Sm;

end Gen_IL.Gen;