------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                                A T R E E                                 --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--          Copyright (C) 1992-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.      --
--                                                                          --
------------------------------------------------------------------------------

--  WARNING: There is a C version of this package. Any changes to this source
--  file must be properly reflected in the file atree.h which is a C header
--  file containing equivalent definitions for use by gigi.

--  Checks and assertions in this package are too slow, and are mostly needed
--  when working on this package itself, or on gen_il, so we disable them.
--  To debug low-level bugs in this area, comment out the following pragmas,
--  and run with -gnatd_v.

pragma Suppress (All_Checks);
pragma Assertion_Policy (Ignore);

with Aspects;        use Aspects;
with Debug;          use Debug;
with Namet;          use Namet;
with Nlists;         use Nlists;
with Opt;            use Opt;
with Output;         use Output;
with Seinfo;         use Seinfo;
with Sinfo.Utils;    use Sinfo.Utils;
with System.Storage_Elements;

package body Atree is

   ---------------
   -- Debugging --
   ---------------

   --  Suppose you find that node 12345 is messed up. You might want to find
   --  the code that created that node. See sinfo-utils.adb for how to do that.

   Ignored_Ghost_Recording_Proc : Ignored_Ghost_Record_Proc := null;
   --  This soft link captures the procedure invoked during the creation of an
   --  ignored Ghost node or entity.

   Locked : Boolean := False;
   --  Compiling with assertions enabled, node contents modifications are
   --  permitted only when this switch is set to False; compiling without
   --  assertions this lock has no effect.

   Reporting_Proc : Report_Proc := null;
   --  Set_Reporting_Proc sets this. Set_Reporting_Proc must be called only
   --  once.

   Rewriting_Proc : Rewrite_Proc := null;
   --  This soft link captures the procedure invoked during a node rewrite

   -----------------------------
   -- Local Objects and Types --
   -----------------------------

   Comes_From_Source_Default : Boolean := False;

   use Atree_Private_Part;
   --  We are also allowed to see our private data structures

   --------------------------------------------------
   -- Implementation of Tree Substitution Routines --
   --------------------------------------------------

   --  A separate table keeps track of the mapping between rewritten nodes and
   --  their corresponding original tree nodes. Rewrite makes an entry in this
   --  table for use by Original_Node. By default the entry in this table
   --  points to the original unwritten node. Note that if a node is rewritten
   --  more than once, there is no easy way to get to the intermediate
   --  rewrites; the node itself is the latest version, and the entry in this
   --  table is the original.

   --  Note: This could be a node field.

   package Orig_Nodes is new Table.Table (
      Table_Component_Type => Node_Id,
      Table_Index_Type     => Node_Id'Base,
      Table_Low_Bound      => First_Node_Id,
      Table_Initial        => Alloc.Node_Offsets_Initial,
      Table_Increment      => Alloc.Node_Offsets_Increment,
      Table_Name           => "Orig_Nodes");

   --------------------------
   -- Paren_Count Handling --
   --------------------------

   --  The Small_Paren_Count field has range 0 .. 3. If the Paren_Count is
   --  in the range 0 .. 2, then it is stoed as Small_Paren_Count. Otherwise,
   --  Small_Paren_Count = 3, and the actual Paren_Count is stored in the
   --  Paren_Counts table.
   --
   --  We use linear search on the Paren_Counts table, which is plenty
   --  efficient because only pathological programs will use it. Nobody
   --  writes (((X + Y))).

   type Paren_Count_Entry is record
      Nod : Node_Id;
      --  The node to which this count applies

      Count : Nat range 3 .. Nat'Last;
      --  The count of parentheses, which will be in the indicated range
   end record;

   package Paren_Counts is new Table.Table (
     Table_Component_Type => Paren_Count_Entry,
     Table_Index_Type     => Int,
     Table_Low_Bound      => 0,
     Table_Initial        => 10,
     Table_Increment      => 200,
     Table_Name           => "Paren_Counts");

   procedure Set_Paren_Count_Of_Copy (Target, Source : Node_Id);
   pragma Inline (Set_Paren_Count_Of_Copy);
   --  Called when copying a node. Makes sure the Paren_Count of the copy is
   --  correct.

   -----------------------
   -- Local Subprograms --
   -----------------------

   function Is_Entity (N : Node_Or_Entity_Id) return Boolean;
   pragma Inline (Is_Entity);
   --  Returns True if N is an entity

   function Allocate_New_Node (Kind : Node_Kind) return Node_Id;
   pragma Inline (Allocate_New_Node);
   --  Allocate a new node or first part of a node extension. Initialize the
   --  Nodes.Table entry, Flags, Orig_Nodes, and List tables.

   procedure Fix_Parents (Ref_Node, Fix_Node : Node_Id);
   --  Fix up parent pointers for the children of Fix_Node after a copy,
   --  setting them to Fix_Node when they pointed to Ref_Node.

   procedure Mark_New_Ghost_Node (N : Node_Or_Entity_Id);
   --  Mark arbitrary node or entity N as Ghost when it is created within a
   --  Ghost region.

   procedure Report (Target, Source : Node_Id);
   pragma Inline (Report);
   --  Invoke the reporting procedure if available

   function Size_In_Slots (N : Node_Or_Entity_Id) return Field_Offset;
   --  Number of slots belonging to N. This can be less than
   --  Size_In_Slots_To_Alloc for entities.

   function Size_In_Slots_To_Alloc (N : Node_Or_Entity_Id) return Field_Offset;
   function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Field_Offset;
   --  Number of slots to allocate for a node or entity. For entities, we have
   --  to allocate the max, because we don't know the Ekind when this is
   --  called.

   function Off_0 (N : Node_Id) return Node_Offset;
   --  Offset of the first slot of N (offset 0) in Slots.Table

   function Off_L (N : Node_Id) return Node_Offset;
   --  Offset of the last slot of N in Slots.Table

   procedure Zero_Slots (F, L : Node_Offset) with Inline;
   --  Set slots in the range F..L to zero

   procedure Zero_Slots (N : Node_Or_Entity_Id) with Inline;
   --  Zero the slots belonging to N

   procedure Copy_Slots (From, To, Num_Slots : Node_Offset) with Inline;
   --  Copy Num_Slots slots from From to To

   procedure Copy_Slots (Source, Destination : Node_Id) with Inline;
   --  Copies the slots of Source to Destination

   function Get_Field_Value
     (N : Node_Id; Field : Node_Field) return Field_32_Bit;
   --  Get any field value as a Field_32_Bit. If the field is smaller than 32
   --  bits, convert it to Field_32_Bit.

   procedure Set_Field_Value
     (N : Node_Id; Field : Node_Field; Val : Field_32_Bit);
   --  Set any field value as a Field_32_Bit. If the field is smaller than 32
   --  bits, convert it from Field_32_Bit, and Val had better be small enough.

   procedure Check_Vanishing_Fields
     (Old_N : Node_Id; New_Kind : Node_Kind);
   --  Called whenever Nkind is modified. Raises an exception if not all
   --  vanishing fields are in their initial zero state.

   function Get_Field_Value
     (N : Entity_Id; Field : Entity_Field) return Field_32_Bit;
   procedure Set_Field_Value
     (N : Entity_Id; Field : Entity_Field; Val : Field_32_Bit);
   procedure Check_Vanishing_Fields
     (Old_N : Entity_Id; New_Kind : Entity_Kind);
   --  Above are the same as the ones for nodes, but for entities

   procedure Init_Nkind (N : Node_Id; Val : Node_Kind);
   --  Initialize the Nkind field, which must not have been set already. This
   --  cannot be used to modify an already-initialized Nkind field. See also
   --  Mutate_Nkind.

   procedure Mutate_Nkind
     (N : Node_Id; Val : Node_Kind; Old_Size : Field_Offset);
   --  Called by the other Mutate_Nkind to do all the work. This is needed
   --  because the call in Change_Node, which calls this one directly, happens
   --  after zeroing N's slots, which destroys its Nkind, which prevents us
   --  from properly computing Old_Size.

   package Field_Checking is
      function Field_Present
        (Kind : Node_Kind; Field : Node_Field) return Boolean;
      function Field_Present
        (Kind : Entity_Kind; Field : Entity_Field) return Boolean;
   end Field_Checking;

   package body Field_Checking is

      --  Tables used by Field_Present

      type Node_Field_Sets is array (Node_Kind) of Node_Field_Set;
      type Node_Field_Sets_Ptr is access all Node_Field_Sets;
      Node_Fields_Present : Node_Field_Sets_Ptr;

      type Entity_Field_Sets is array (Entity_Kind) of Entity_Field_Set;
      type Entity_Field_Sets_Ptr is access all Entity_Field_Sets;
      Entity_Fields_Present : Entity_Field_Sets_Ptr;

      procedure Init_Tables;

      function Fields_Present (Kind : Node_Kind) return Node_Field_Set;
      function Fields_Present (Kind : Entity_Kind) return Entity_Field_Set;
      --  Computes the set of fields present in each Node/Entity Kind. Used to
      --  initialize the above tables.

      --------------------
      -- Fields_Present --
      --------------------

      function Fields_Present (Kind : Node_Kind) return Node_Field_Set is
         Result : Node_Field_Set := (others => False);
      begin
         for J in Node_Field_Table (Kind)'Range loop
            Result (Node_Field_Table (Kind) (J)) := True;
         end loop;

         return Result;
      end Fields_Present;

      function Fields_Present (Kind : Entity_Kind) return Entity_Field_Set is
         Result : Entity_Field_Set := (others => False);
      begin
         for J in Entity_Field_Table (Kind)'Range loop
            Result (Entity_Field_Table (Kind) (J)) := True;
         end loop;

         return Result;
      end Fields_Present;

      procedure Init_Tables is
      begin
         Node_Fields_Present := new Node_Field_Sets;

         for Kind in Node_Kind loop
            Node_Fields_Present (Kind) := Fields_Present (Kind);
         end loop;

         Entity_Fields_Present := new Entity_Field_Sets;

         for Kind in Entity_Kind loop
            Entity_Fields_Present (Kind) := Fields_Present (Kind);
         end loop;
      end Init_Tables;

      --  In production mode, we leave Node_Fields_Present and
      --  Entity_Fields_Present null. Field_Present is only for
      --  use in assertions.

      pragma Debug (Init_Tables);

      function Field_Present
        (Kind : Node_Kind; Field : Node_Field) return Boolean is
      begin
         if Node_Fields_Present = null then
            return True;
         end if;

         return Node_Fields_Present (Kind) (Field);
      end Field_Present;

      function Field_Present
        (Kind : Entity_Kind; Field : Entity_Field) return Boolean is
      begin
         if Entity_Fields_Present = null then
            return True;
         end if;

         return Entity_Fields_Present (Kind) (Field);
      end Field_Present;

   end Field_Checking;

   ------------------------
   -- Atree_Private_Part --
   ------------------------

   package body Atree_Private_Part is

      --  The following validators are disabled in production builds, by being
      --  called in pragma Debug. They are also disabled by default in debug
      --  builds, by setting the flags below, because they make the compiler
      --  very slow (10 to 20 times slower). Validate can be set True to debug
      --  the low-level accessors.
      --
      --  Even if Validate is True, validation is disabled during
      --  Validate_... calls to prevent infinite recursion
      --  (Validate_... procedures call field getters, which call
      --  Validate_... procedures). That's what the Enable_Validate_...
      --  flags are for; they are toggled so that when we're inside one
      --  of them, and enter it again, the inner call doesn't do anything.
      --  These flags are irrelevant when Validate is False.

      Validate : constant Boolean := False;

      Enable_Validate_Node,
      Enable_Validate_Node_Write,
      Enable_Validate_Node_And_Offset,
      Enable_Validate_Node_And_Offset_Write :
        Boolean := Validate;

      procedure Validate_Node_And_Offset
        (N : Node_Or_Entity_Id; Offset : Field_Offset);
      procedure Validate_Node_And_Offset_Write
        (N : Node_Or_Entity_Id; Offset : Field_Offset);
      --  Asserts N is OK, and the Offset in slots is within N. Note that this
      --  does not guarantee that the offset is valid, just that it's not past
      --  the last slot. It could be pointing at unused bits within the node,
      --  or unused padding at the end.

      procedure Validate_Node_And_Offset
        (N : Node_Or_Entity_Id; Offset : Field_Offset) is
      begin
         if Enable_Validate_Node_And_Offset then
            Enable_Validate_Node_And_Offset := False;

            pragma Debug (Validate_Node (N));
            pragma Assert (Offset'Valid);
            pragma Assert (Offset < Size_In_Slots (N));

            Enable_Validate_Node_And_Offset := True;
         end if;
      end Validate_Node_And_Offset;

      procedure Validate_Node_And_Offset_Write
        (N : Node_Or_Entity_Id; Offset : Field_Offset) is
      begin
         if Enable_Validate_Node_And_Offset_Write then
            Enable_Validate_Node_And_Offset_Write := False;

            pragma Debug (Validate_Node_Write (N));
            pragma Assert (Offset'Valid);
            pragma Assert (Offset < Size_In_Slots (N));

            Enable_Validate_Node_And_Offset_Write := True;
         end if;
      end Validate_Node_And_Offset_Write;

      procedure Validate_Node (N : Node_Or_Entity_Id) is
      begin
         if Enable_Validate_Node then
            Enable_Validate_Node := False;

            pragma Assert (N'Valid);
            pragma Assert (N <= Node_Offsets.Last);
            pragma Assert (Off_0 (N) < Off_L (N));
            pragma Assert (Off_L (N) <= Slots.Last);
            pragma Assert (Nkind (N)'Valid);
            pragma Assert (Nkind (N) /= N_Unused_At_End);

            if Nkind (N) in N_Entity then
               pragma Assert (Ekind (N)'Valid);
            end if;

            if Nkind (N) in N_Attribute_Definition_Clause
                          | N_Has_Entity
                          | N_Aggregate
                          | N_Extension_Aggregate
                          | N_Selected_Component
                          | N_Use_Package_Clause
                          | N_Aspect_Specification
                          | N_Freeze_Entity
                          | N_Freeze_Generic_Entity
            then
               pragma Assert (Entity_Or_Associated_Node (N)'Valid);
            end if;

            Enable_Validate_Node := True;
         end if;
      end Validate_Node;

      procedure Validate_Node_Write (N : Node_Or_Entity_Id) is
      begin
         if Enable_Validate_Node_Write then
            Enable_Validate_Node_Write := False;

            pragma Debug (Validate_Node (N));
            pragma Assert (not Locked);

            Enable_Validate_Node_Write := True;
         end if;
      end Validate_Node_Write;

      function Is_Valid_Node (U : Union_Id) return Boolean is
      begin
         return Node_Id'Base (U) <= Node_Offsets.Last;
      end Is_Valid_Node;

      function Alloc_Node_Id return Node_Id is
      begin
         Node_Offsets.Increment_Last;
         return Node_Offsets.Last;
      end Alloc_Node_Id;

      function Alloc_Slots (Num_Slots : Field_Offset) return Node_Offset is
      begin
         return Result : constant Node_Offset := Slots.Last + 1 do
            Slots.Set_Last (Slots.Last + Num_Slots);
         end return;
      end Alloc_Slots;

      function Get_1_Bit_Field
        (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
      is
         pragma Assert (Field_Type'Size = 1);

         function Cast is new Unchecked_Conversion (Field_1_Bit, Field_Type);
      begin
         return Cast (Get_1_Bit_Val (N, Offset));
      end Get_1_Bit_Field;

      function Get_2_Bit_Field
        (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
      is
         pragma Assert (Field_Type'Size = 2);

         function Cast is new Unchecked_Conversion (Field_2_Bit, Field_Type);
      begin
         return Cast (Get_2_Bit_Val (N, Offset));
      end Get_2_Bit_Field;

      function Get_4_Bit_Field
        (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
      is
         pragma Assert (Field_Type'Size = 4);

         function Cast is new Unchecked_Conversion (Field_4_Bit, Field_Type);
      begin
         return Cast (Get_4_Bit_Val (N, Offset));
      end Get_4_Bit_Field;

      function Get_8_Bit_Field
        (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
      is
         pragma Assert (Field_Type'Size = 8);

         function Cast is new Unchecked_Conversion (Field_8_Bit, Field_Type);
      begin
         return Cast (Get_8_Bit_Val (N, Offset));
      end Get_8_Bit_Field;

      function Get_32_Bit_Field
        (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
      is
         pragma Assert (Field_Type'Size = 32);

         function Cast is new Unchecked_Conversion (Field_32_Bit, Field_Type);
      begin
         return Cast (Get_32_Bit_Val (N, Offset));
      end Get_32_Bit_Field;

      function Get_32_Bit_Field_With_Default
        (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_Type
      is
         function Get_Field is new Get_32_Bit_Field (Field_Type) with Inline;
      begin
         --  If the field has not yet been set, it will be equal to zero.
         --  That is of the "wrong" type, so we fetch it as a Field_32_Bit.

         if Get_32_Bit_Val (N, Offset) = 0 then
            return Default_Val;

         else
            return Get_Field (N, Offset);
         end if;
      end Get_32_Bit_Field_With_Default;

      procedure Set_1_Bit_Field
        (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type)
      is
         pragma Assert (Field_Type'Size = 1);

         function Cast is new Unchecked_Conversion (Field_Type, Field_1_Bit);
      begin
         Set_1_Bit_Val (N, Offset, Cast (Val));
      end Set_1_Bit_Field;

      procedure Set_2_Bit_Field
        (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type)
      is
         pragma Assert (Field_Type'Size = 2);

         function Cast is new Unchecked_Conversion (Field_Type, Field_2_Bit);
      begin
         Set_2_Bit_Val (N, Offset, Cast (Val));
      end Set_2_Bit_Field;

      procedure Set_4_Bit_Field
        (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type)
      is
         pragma Assert (Field_Type'Size = 4);

         function Cast is new Unchecked_Conversion (Field_Type, Field_4_Bit);
      begin
         Set_4_Bit_Val (N, Offset, Cast (Val));
      end Set_4_Bit_Field;

      procedure Set_8_Bit_Field
        (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type)
      is
         pragma Assert (Field_Type'Size = 8);

         function Cast is new Unchecked_Conversion (Field_Type, Field_8_Bit);
      begin
         Set_8_Bit_Val (N, Offset, Cast (Val));
      end Set_8_Bit_Field;

      procedure Set_32_Bit_Field
        (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_Type)
      is
         pragma Assert (Field_Type'Size = 32);

         function Cast is new Unchecked_Conversion (Field_Type, Field_32_Bit);
      begin
         Set_32_Bit_Val (N, Offset, Cast (Val));
      end Set_32_Bit_Field;

      function Get_1_Bit_Val
        (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_1_Bit
      is
         --  We wish we were using packed arrays, but instead we're simulating
         --  them with modular integers. L here (and elsewhere) is the 'Length
         --  of that simulated array.
         L : constant Field_Offset := Slot_Size / 1;

         pragma Debug (Validate_Node_And_Offset (N, Offset / L));

         S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
         V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
      begin
         return Field_1_Bit (Shift_Right (S, V) and 1);
      end Get_1_Bit_Val;

      function Get_2_Bit_Val
        (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_2_Bit
      is
         L : constant Field_Offset := Slot_Size / 2;

         pragma Debug (Validate_Node_And_Offset (N, Offset / L));

         S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
         V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
      begin
         return Field_2_Bit (Shift_Right (S, V) and 3);
      end Get_2_Bit_Val;

      function Get_4_Bit_Val
        (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_4_Bit
      is
         L : constant Field_Offset := Slot_Size / 4;

         pragma Debug (Validate_Node_And_Offset (N, Offset / L));

         S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
         V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
      begin
         return Field_4_Bit (Shift_Right (S, V) and 15);
      end Get_4_Bit_Val;

      function Get_8_Bit_Val
        (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_8_Bit
      is
         L : constant Field_Offset := Slot_Size / 8;

         pragma Debug (Validate_Node_And_Offset (N, Offset / L));

         S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
         V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
      begin
         return Field_8_Bit (Shift_Right (S, V) and 255);
      end Get_8_Bit_Val;

      function Get_32_Bit_Val
        (N : Node_Or_Entity_Id; Offset : Field_Offset) return Field_32_Bit
      is
         pragma Debug (Validate_Node_And_Offset (N, Offset));

         S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset);
      begin
         return Field_32_Bit (S);
      end Get_32_Bit_Val;

      procedure Set_1_Bit_Val
        (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_1_Bit)
      is
         L : constant Field_Offset := Slot_Size / 1;

         pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L));

         S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
         V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
      begin
         S := (S and not Shift_Left (1, V)) or Shift_Left (Slot (Val), V);
      end Set_1_Bit_Val;

      procedure Set_2_Bit_Val
        (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_2_Bit)
      is
         L : constant Field_Offset := Slot_Size / 2;

         pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L));

         S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
         V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
      begin
         S := (S and not Shift_Left (3, V)) or Shift_Left (Slot (Val), V);
      end Set_2_Bit_Val;

      procedure Set_4_Bit_Val
        (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_4_Bit)
      is
         L : constant Field_Offset := Slot_Size / 4;

         pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L));

         S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
         V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
      begin
         S := (S and not Shift_Left (15, V)) or Shift_Left (Slot (Val), V);
      end Set_4_Bit_Val;

      procedure Set_8_Bit_Val
        (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_8_Bit)
      is
         L : constant Field_Offset := Slot_Size / 8;

         pragma Debug (Validate_Node_And_Offset_Write (N, Offset / L));

         S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset / L);
         V : constant Natural := Natural ((Offset mod L) * (Slot_Size / L));
      begin
         S := (S and not Shift_Left (255, V)) or Shift_Left (Slot (Val), V);
      end Set_8_Bit_Val;

      procedure Set_32_Bit_Val
        (N : Node_Or_Entity_Id; Offset : Field_Offset; Val : Field_32_Bit)
      is
         pragma Debug (Validate_Node_And_Offset_Write (N, Offset));

         S : Slot renames Slots.Table (Node_Offsets.Table (N) + Offset);
      begin
         S := Slot (Val);
      end Set_32_Bit_Val;

   end Atree_Private_Part;

   ---------------
   -- Set_Field --
   ---------------

   function Get_Node_Field_Union is new Get_32_Bit_Field (Union_Id)
     with Inline;
   --  Called when we don't know whether a field is a Node_Id or a List_Id,
   --  etc.

   function Get_Field_Value
     (N : Node_Id; Field : Node_Field) return Field_32_Bit
   is
      pragma Assert (Field_Checking.Field_Present (Nkind (N), Field));
      Desc : Field_Descriptor renames Node_Field_Descriptors (Field);

   begin
      case Field_Size (Desc.Kind) is
         when 1 => return Field_32_Bit (Get_1_Bit_Val (N, Desc.Offset));
         when 2 => return Field_32_Bit (Get_2_Bit_Val (N, Desc.Offset));
         when 4 => return Field_32_Bit (Get_4_Bit_Val (N, Desc.Offset));
         when 8 => return Field_32_Bit (Get_8_Bit_Val (N, Desc.Offset));
         when others => return Get_32_Bit_Val (N, Desc.Offset);  -- 32
      end case;
   end Get_Field_Value;

   procedure Set_Field_Value
     (N : Node_Id; Field : Node_Field; Val : Field_32_Bit)
   is
      pragma Assert (Field_Checking.Field_Present (Nkind (N), Field));
      Desc : Field_Descriptor renames Node_Field_Descriptors (Field);

   begin
      case Field_Size (Desc.Kind) is
         when 1 => Set_1_Bit_Val (N, Desc.Offset, Field_1_Bit (Val));
         when 2 => Set_2_Bit_Val (N, Desc.Offset, Field_2_Bit (Val));
         when 4 => Set_4_Bit_Val (N, Desc.Offset, Field_4_Bit (Val));
         when 8 => Set_8_Bit_Val (N, Desc.Offset, Field_8_Bit (Val));
         when others => Set_32_Bit_Val (N, Desc.Offset, Val);  -- 32
      end case;
   end Set_Field_Value;

   procedure Reinit_Field_To_Zero (N : Node_Id; Field : Node_Field) is
   begin
      Set_Field_Value (N, Field, 0);
   end Reinit_Field_To_Zero;

   function Field_Is_Initial_Zero
     (N : Node_Id; Field : Node_Field) return Boolean is
   begin
      return Get_Field_Value (N, Field) = 0;
   end Field_Is_Initial_Zero;

   procedure Reinit_Field_To_Zero
     (N : Node_Id; Field : Entity_Field; Old_Ekind : Entity_Kind_Set) is
   begin
      pragma Assert (Old_Ekind (Ekind (N)), "Reinit: " & Ekind (N)'Img);
      Reinit_Field_To_Zero (N, Field);
   end Reinit_Field_To_Zero;

   procedure Reinit_Field_To_Zero
     (N : Node_Id; Field : Entity_Field; Old_Ekind : Entity_Kind) is
      Old_Ekind_Set : Entity_Kind_Set := (others => False);
   begin
      Old_Ekind_Set (Old_Ekind) := True;
      Reinit_Field_To_Zero (N, Field, Old_Ekind => Old_Ekind_Set);
   end Reinit_Field_To_Zero;

   procedure Check_Vanishing_Fields
     (Old_N : Node_Id; New_Kind : Node_Kind)
   is
      Old_Kind : constant Node_Kind := Nkind (Old_N);

      --  If this fails, it means you need to call Reinit_Field_To_Zero before
      --  calling Set_Nkind.

   begin
      for J in Node_Field_Table (Old_Kind)'Range loop
         declare
            F : constant Node_Field := Node_Field_Table (Old_Kind) (J);
         begin
            if not Field_Checking.Field_Present (New_Kind, F) then
               if not Field_Is_Initial_Zero (Old_N, F) then
                  Write_Str (Old_Kind'Img);
                  Write_Str (" --> ");
                  Write_Str (New_Kind'Img);
                  Write_Str (" Nonzero field ");
                  Write_Str (F'Img);
                  Write_Str (" is vanishing");
                  Write_Eol;

                  raise Program_Error;
               end if;
            end if;
         end;
      end loop;
   end Check_Vanishing_Fields;

   function Get_Field_Value
     (N : Entity_Id; Field : Entity_Field) return Field_32_Bit
   is
      pragma Assert (Field_Checking.Field_Present (Ekind (N), Field));
      Desc : Field_Descriptor renames Entity_Field_Descriptors (Field);
   begin
      case Field_Size (Desc.Kind) is
         when 1 => return Field_32_Bit (Get_1_Bit_Val (N, Desc.Offset));
         when 2 => return Field_32_Bit (Get_2_Bit_Val (N, Desc.Offset));
         when 4 => return Field_32_Bit (Get_4_Bit_Val (N, Desc.Offset));
         when 8 => return Field_32_Bit (Get_8_Bit_Val (N, Desc.Offset));
         when others => return Get_32_Bit_Val (N, Desc.Offset);  -- 32
      end case;
   end Get_Field_Value;

   procedure Set_Field_Value
     (N : Entity_Id; Field : Entity_Field; Val : Field_32_Bit)
   is
      pragma Assert (Field_Checking.Field_Present (Ekind (N), Field));
      Desc : Field_Descriptor renames Entity_Field_Descriptors (Field);
   begin
      case Field_Size (Desc.Kind) is
         when 1 => Set_1_Bit_Val (N, Desc.Offset, Field_1_Bit (Val));
         when 2 => Set_2_Bit_Val (N, Desc.Offset, Field_2_Bit (Val));
         when 4 => Set_4_Bit_Val (N, Desc.Offset, Field_4_Bit (Val));
         when 8 => Set_8_Bit_Val (N, Desc.Offset, Field_8_Bit (Val));
         when others => Set_32_Bit_Val (N, Desc.Offset, Val);  -- 32
      end case;
   end Set_Field_Value;

   procedure Reinit_Field_To_Zero (N : Node_Id; Field : Entity_Field) is
   begin
      Set_Field_Value (N, Field, 0);
   end Reinit_Field_To_Zero;

   function Field_Is_Initial_Zero
     (N : Entity_Id; Field : Entity_Field) return Boolean is
   begin
      return Get_Field_Value (N, Field) = 0;
   end Field_Is_Initial_Zero;

   procedure Check_Vanishing_Fields
     (Old_N : Entity_Id; New_Kind : Entity_Kind)
   is
      Old_Kind : constant Entity_Kind := Ekind (Old_N);

      --  If this fails, it means you need to call Reinit_Field_To_Zero before
      --  calling Mutate_Ekind. But we have many cases where vanishing fields
      --  are expected to reappear after converting to/from E_Void. Other cases
      --  are more problematic; set a breakpoint on "(non-E_Void case)" below.

   begin
      for J in Entity_Field_Table (Old_Kind)'Range loop
         declare
            F : constant Entity_Field := Entity_Field_Table (Old_Kind) (J);
         begin
            if not Field_Checking.Field_Present (New_Kind, F) then
               if not Field_Is_Initial_Zero (Old_N, F) then
                  Write_Str (Old_Kind'Img);
                  Write_Str (" --> ");
                  Write_Str (New_Kind'Img);
                  Write_Str (" Nonzero field ");
                  Write_Str (F'Img);
                  Write_Str (" is vanishing ");
                  Write_Eol;

                  if New_Kind = E_Void or else Old_Kind = E_Void then
                     Write_Line ("    (E_Void case)");
                  else
                     Write_Line ("    (non-E_Void case)");
                  end if;
               end if;
            end if;
         end;
      end loop;
   end Check_Vanishing_Fields;

   Nkind_Offset : constant Field_Offset :=
     Node_Field_Descriptors (Nkind).Offset;

   procedure Set_Nkind_Type is new Set_8_Bit_Field (Node_Kind) with Inline;

   procedure Init_Nkind (N : Node_Id; Val : Node_Kind) is
      pragma Assert (Field_Is_Initial_Zero (N, Nkind));
   begin
      Set_Nkind_Type (N, Nkind_Offset, Val);
   end Init_Nkind;

   procedure Mutate_Nkind
     (N : Node_Id; Val : Node_Kind; Old_Size : Field_Offset)
   is
      New_Size : constant Field_Offset := Size_In_Slots_To_Alloc (Val);

      All_Node_Offsets : Node_Offsets.Table_Type renames
        Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
   begin
      pragma Debug (Check_Vanishing_Fields (N, Val));

      --  Grow the slots if necessary

      if Old_Size < New_Size then
         declare
            Old_Last_Slot : constant Node_Offset := Slots.Last;
            Old_Off_0 : constant Node_Offset := Off_0 (N);
         begin
            if Old_Last_Slot = Old_Off_0 + Old_Size - 1 then
               --  In this case, the slots are at the end of Slots.Table, so we
               --  don't need to move them.
               Slots.Set_Last (Old_Last_Slot + New_Size - Old_Size);

            else
               --  Move the slots
               All_Node_Offsets (N) := Alloc_Slots (New_Size);
               Copy_Slots (Old_Off_0, Off_0 (N), Old_Size);
               pragma Debug (Zero_Slots (Old_Off_0, Old_Off_0 + Old_Size - 1));
            end if;
         end;

         Zero_Slots (Off_0 (N) + Old_Size, Slots.Last);
      end if;

      Set_Nkind_Type (N, Nkind_Offset, Val);
      pragma Debug (Validate_Node_Write (N));
   end Mutate_Nkind;

   procedure Mutate_Nkind (N : Node_Id; Val : Node_Kind) is
   begin
      Mutate_Nkind (N, Val, Old_Size => Size_In_Slots (N));
   end Mutate_Nkind;

   Ekind_Offset : constant Field_Offset :=
     Entity_Field_Descriptors (Ekind).Offset;

   procedure Set_Ekind_Type is new Set_8_Bit_Field (Entity_Kind) with Inline;

   procedure Mutate_Ekind
     (N : Entity_Id; Val : Entity_Kind)
   is
   begin
      if Ekind (N) = Val then
         return;
      end if;

      if Debug_Flag_Underscore_V then
         pragma Debug (Check_Vanishing_Fields (N, Val));
      end if;

      --  For now, we are allocating all entities with the same size, so we
      --  don't need to reallocate slots here.

      Set_Ekind_Type (N, Ekind_Offset, Val);
      pragma Debug (Validate_Node_Write (N));
   end Mutate_Ekind;

   -----------------------
   -- Allocate_New_Node --
   -----------------------

   function Allocate_New_Node (Kind : Node_Kind) return Node_Id is
   begin
      return Result : constant Node_Id := Alloc_Node_Id do
         declare
            Sz : constant Field_Offset := Size_In_Slots_To_Alloc (Kind);
            Sl : constant Node_Offset := Alloc_Slots (Sz);
         begin
            Node_Offsets.Table (Result) := Sl;
            Zero_Slots (Sl, Sl + Sz - 1);
         end;

         Init_Nkind (Result, Kind);

         Orig_Nodes.Append (Result);
         Set_Comes_From_Source (Result, Comes_From_Source_Default);
         Allocate_List_Tables (Result);
         Report (Target => Result, Source => Empty);
      end return;
   end Allocate_New_Node;

   --------------------------
   -- Check_Error_Detected --
   --------------------------

   procedure Check_Error_Detected is
   begin
      --  An anomaly has been detected which is assumed to be a consequence of
      --  a previous serious error or configurable run time violation. Raise
      --  an exception if no such error has been detected.

      if Serious_Errors_Detected = 0
        and then Configurable_Run_Time_Violations = 0
      then
         raise Program_Error;
      end if;
   end Check_Error_Detected;

   -----------------
   -- Change_Node --
   -----------------

   procedure Change_Node (N : Node_Id; New_Kind : Node_Kind) is
      pragma Debug (Validate_Node_Write (N));
      pragma Assert (Nkind (N) not in N_Entity);
      pragma Assert (New_Kind not in N_Entity);

      Old_Size : constant Field_Offset := Size_In_Slots (N);
      New_Size : constant Field_Offset := Size_In_Slots_To_Alloc (New_Kind);

      Save_Sloc    : constant Source_Ptr := Sloc (N);
      Save_In_List : constant Boolean    := In_List (N);
      Save_CFS     : constant Boolean    := Comes_From_Source (N);
      Save_Posted  : constant Boolean    := Error_Posted (N);
      Save_CA     : constant Boolean := Check_Actuals (N);
      Save_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (N);
      Save_Link    : constant Union_Id   := Link (N);

      Par_Count : Nat := 0;

   begin
      if Nkind (N) in N_Subexpr then
         Par_Count := Paren_Count (N);
      end if;

      if New_Size > Old_Size then
         declare
            New_Offset : constant Field_Offset := Alloc_Slots (New_Size);
         begin
            pragma Debug (Zero_Slots (N));
            Node_Offsets.Table (N) := New_Offset;
            Zero_Slots (New_Offset, New_Offset + New_Size - 1);
         end;

      else
         Zero_Slots (N);
      end if;

      Mutate_Nkind (N, New_Kind, Old_Size);

      Set_Sloc (N, Save_Sloc);
      Set_In_List (N, Save_In_List);
      Set_Comes_From_Source (N, Save_CFS);
      Set_Error_Posted (N, Save_Posted);
      Set_Check_Actuals (N, Save_CA);
      Set_Is_Ignored_Ghost_Node (N, Save_Is_IGN);
      Set_Link (N, Save_Link);

      if New_Kind in N_Subexpr then
         Set_Paren_Count (N, Par_Count);
      end if;
   end Change_Node;

   ---------------
   -- Copy_Node --
   ---------------

   procedure Copy_Slots (From, To, Num_Slots : Node_Offset) is
      pragma Assert (From /= To);

      All_Slots : Slots.Table_Type renames
        Slots.Table (Slots.First .. Slots.Last);

      Source_Slots : Slots.Table_Type renames
        All_Slots (From .. From + Num_Slots - 1);

      Destination_Slots : Slots.Table_Type renames
        All_Slots (To .. To + Num_Slots - 1);

   begin
      Destination_Slots := Source_Slots;
   end Copy_Slots;

   procedure Copy_Slots (Source, Destination : Node_Id) is
      pragma Debug (Validate_Node (Source));
      pragma Debug (Validate_Node_Write (Destination));
      pragma Assert (Source /= Destination);

      S_Size : constant Field_Offset := Size_In_Slots (Source);

      All_Node_Offsets : Node_Offsets.Table_Type renames
        Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);

   begin
      Copy_Slots
        (All_Node_Offsets (Source), All_Node_Offsets (Destination), S_Size);
   end Copy_Slots;

   ---------------
   -- Copy_Node --
   ---------------

   procedure Copy_Node (Source, Destination : Node_Or_Entity_Id) is
      pragma Assert (Source /= Destination);

      Save_In_List : constant Boolean  := In_List (Destination);
      Save_Link    : constant Union_Id := Link (Destination);

      S_Size : constant Field_Offset := Size_In_Slots_To_Alloc (Source);
      D_Size : constant Field_Offset := Size_In_Slots_To_Alloc (Destination);

   begin
      New_Node_Debugging_Output (Source);
      New_Node_Debugging_Output (Destination);

      --  Currently all entities are allocated the same number of slots.
      --  Hopefully that won't always be the case, but if it is, the following
      --  is suboptimal if D_Size < S_Size, because in fact the Destination was
      --  allocated the max.

      --  If Source doesn't fit in Destination, we need to allocate

      if D_Size < S_Size then
         pragma Debug (Zero_Slots (Destination)); -- destroy old slots
         Node_Offsets.Table (Destination) := Alloc_Slots (S_Size);
      end if;

      Copy_Slots (Source, Destination);

      Set_In_List (Destination, Save_In_List);
      Set_Link (Destination, Save_Link);

      Set_Paren_Count_Of_Copy (Target => Destination, Source => Source);
   end Copy_Node;

   ------------------------
   -- Copy_Separate_List --
   ------------------------

   function Copy_Separate_List (Source : List_Id) return List_Id is
      Result : constant List_Id := New_List;
      Nod    : Node_Id := First (Source);

   begin
      while Present (Nod) loop
         Append (Copy_Separate_Tree (Nod), Result);
         Next (Nod);
      end loop;

      return Result;
   end Copy_Separate_List;

   ------------------------
   -- Copy_Separate_Tree --
   ------------------------

   function Copy_Separate_Tree (Source : Node_Id) return Node_Id is

      pragma Debug (Validate_Node (Source));

      New_Id : Node_Id;

      function Copy_Entity (E : Entity_Id) return Entity_Id;
      --  Copy Entity, copying only Chars field

      function Copy_List (List : List_Id) return List_Id;
      --  Copy list

      function Possible_Copy (Field : Union_Id) return Union_Id;
      --  Given a field, returns a copy of the node or list if its parent is
      --  the current source node, and otherwise returns the input.

      -----------------
      -- Copy_Entity --
      -----------------

      function Copy_Entity (E : Entity_Id) return Entity_Id is
      begin
         pragma Assert (Nkind (E) in N_Entity);

         return Result : constant Entity_Id := New_Entity (Nkind (E), Sloc (E))
         do
            Set_Chars (Result, Chars (E));
         end return;
      end Copy_Entity;

      ---------------
      -- Copy_List --
      ---------------

      function Copy_List (List : List_Id) return List_Id is
         NL : List_Id;
         E  : Node_Id;

      begin
         if List = No_List then
            return No_List;

         else
            NL := New_List;

            E := First (List);
            while Present (E) loop
               if Is_Entity (E) then
                  Append (Copy_Entity (E), NL);
               else
                  Append (Copy_Separate_Tree (E), NL);
               end if;

               Next (E);
            end loop;

            return NL;
         end if;
      end Copy_List;

      -------------------
      -- Possible_Copy --
      -------------------

      function Possible_Copy (Field : Union_Id) return Union_Id is
         New_N : Union_Id;

      begin
         if Field in Node_Range then
            New_N := Union_Id (Copy_Separate_Tree (Node_Id (Field)));

            if Parent (Node_Id (Field)) = Source then
               Set_Parent (Node_Id (New_N), New_Id);
            end if;

            return New_N;

         elsif Field in List_Range then
            New_N := Union_Id (Copy_List (List_Id (Field)));

            if Parent (List_Id (Field)) = Source then
               Set_Parent (List_Id (New_N), New_Id);
            end if;

            return New_N;

         else
            return Field;
         end if;
      end Possible_Copy;

      procedure Walk is new Walk_Sinfo_Fields_Pairwise (Possible_Copy);

   --  Start of processing for Copy_Separate_Tree

   begin
      if Source <= Empty_Or_Error then
         return Source;

      elsif Is_Entity (Source) then
         return Copy_Entity (Source);

      else
         New_Id := New_Copy (Source);

         Walk (New_Id, Source);

         --  Explicitly copy the aspect specifications as those do not reside
         --  in a node field.

         if Permits_Aspect_Specifications (Source)
           and then Has_Aspects (Source)
         then
            Set_Aspect_Specifications
              (New_Id, Copy_List (Aspect_Specifications (Source)));
         end if;

         --  Set Entity field to Empty to ensure that no entity references
         --  are shared between the two, if the source is already analyzed.

         if Nkind (New_Id) in N_Has_Entity
           or else Nkind (New_Id) = N_Freeze_Entity
         then
            Set_Entity (New_Id, Empty);
         end if;

         --  Reset all Etype fields and Analyzed flags, because input tree may
         --  have been fully or partially analyzed.

         if Nkind (New_Id) in N_Has_Etype then
            Set_Etype (New_Id, Empty);
         end if;

         Set_Analyzed (New_Id, False);

         --  Rather special case, if we have an expanded name, then change
         --  it back into a selected component, so that the tree looks the
         --  way it did coming out of the parser. This will change back
         --  when we analyze the selected component node.

         if Nkind (New_Id) = N_Expanded_Name then

            --  The following code is a bit kludgy. It would be cleaner to
            --  Add an entry Change_Expanded_Name_To_Selected_Component to
            --  Sinfo.CN, but that's delicate because Atree is used in the
            --  binder, so we don't want to add that dependency.
            --  ??? Revisit now that ASIS is no longer using this unit.

            --  Consequently we have no choice but to hold our noses and do the
            --  change manually. At least we are Atree, so this is at least all
            --  in the family.

            --  Clear the Chars field which is not present in a selected
            --  component node, so we don't want a junk value around. Note that
            --  we can't just call Set_Chars, because Empty is of the wrong
            --  type, and is outside the range of Name_Id.

            Reinit_Field_To_Zero (New_Id, Chars);
            Reinit_Field_To_Zero (New_Id, Has_Private_View);
            Reinit_Field_To_Zero (New_Id, Is_Elaboration_Checks_OK_Node);
            Reinit_Field_To_Zero (New_Id, Is_Elaboration_Warnings_OK_Node);
            Reinit_Field_To_Zero (New_Id, Is_SPARK_Mode_On_Node);

            --  Change the node type

            Mutate_Nkind (New_Id, N_Selected_Component);
         end if;

         --  All done, return copied node

         return New_Id;
      end if;
   end Copy_Separate_Tree;

   -----------------------
   -- Exchange_Entities --
   -----------------------

   procedure Exchange_Entities (E1 : Entity_Id; E2 : Entity_Id) is
      pragma Debug (Validate_Node_Write (E1));
      pragma Debug (Validate_Node_Write (E2));
      pragma Assert
        (Is_Entity (E1) and then Is_Entity (E2)
           and then not In_List (E1) and then not In_List (E2));

      Old_E1 : constant Node_Offset := Node_Offsets.Table (E1);

   begin
      Node_Offsets.Table (E1) := Node_Offsets.Table (E2);
      Node_Offsets.Table (E2) := Old_E1;

      --  That exchange exchanged the parent pointers as well, which is what
      --  we want, but we need to patch up the defining identifier pointers
      --  in the parent nodes (the child pointers) to match this switch
      --  unless for Implicit types entities which have no parent, in which
      --  case we don't do anything otherwise we won't be able to revert back
      --  to the original situation.

      --  Shouldn't this use Is_Itype instead of the Parent test???

      if Present (Parent (E1)) and then Present (Parent (E2)) then
         Set_Defining_Identifier (Parent (E1), E1);
         Set_Defining_Identifier (Parent (E2), E2);
      end if;

      New_Node_Debugging_Output (E1);
      New_Node_Debugging_Output (E2);
   end Exchange_Entities;

   -----------------
   -- Extend_Node --
   -----------------

   procedure Extend_Node (Source : Node_Id) is
      pragma Assert (Present (Source));
      pragma Assert (not Is_Entity (Source));

      Old_Kind : constant Node_Kind := Nkind (Source);
      New_Kind : constant Node_Kind :=
        (case Old_Kind is
           when N_Character_Literal => N_Defining_Character_Literal,
           when N_Identifier => N_Defining_Identifier,
           when N_Operator_Symbol => N_Defining_Operator_Symbol,
           when others => N_Abort_Statement); -- can't happen
      --  The new NKind, which is the appropriate value of N_Entity based on
      --  the old Nkind. N_xxx is mapped to N_Defining_xxx.
      pragma Assert (New_Kind in N_Entity);

   --  Start of processing for Extend_Node

   begin
      Set_Check_Actuals (Source, False);
      Mutate_Nkind (Source, New_Kind);
      Report (Target => Source, Source => Source);
   end Extend_Node;

   -----------------
   -- Fix_Parents --
   -----------------

   procedure Fix_Parents (Ref_Node, Fix_Node : Node_Id) is
      pragma Assert (Nkind (Ref_Node) = Nkind (Fix_Node));

      procedure Fix_Parent (Field : Union_Id);
      --  Fix up one parent pointer. Field is checked to see if it points to
      --  a node, list, or element list that has a parent that points to
      --  Ref_Node. If so, the parent is reset to point to Fix_Node.

      ----------------
      -- Fix_Parent --
      ----------------

      procedure Fix_Parent (Field : Union_Id) is
      begin
         --  Fix parent of node that is referenced by Field. Note that we must
         --  exclude the case where the node is a member of a list, because in
         --  this case the parent is the parent of the list.

         if Field in Node_Range
           and then Present (Node_Id (Field))
           and then not In_List (Node_Id (Field))
           and then Parent (Node_Id (Field)) = Ref_Node
         then
            Set_Parent (Node_Id (Field), Fix_Node);

         --  Fix parent of list that is referenced by Field

         elsif Field in List_Range
           and then Present (List_Id (Field))
           and then Parent (List_Id (Field)) = Ref_Node
         then
            Set_Parent (List_Id (Field), Fix_Node);
         end if;
      end Fix_Parent;

      Fields : Node_Field_Array renames
        Node_Field_Table (Nkind (Fix_Node)).all;

   --  Start of processing for Fix_Parents

   begin
      for J in Fields'Range loop
         declare
            Desc : Field_Descriptor renames
              Node_Field_Descriptors (Fields (J));
         begin
            if Desc.Kind in Node_Id_Field | List_Id_Field then
               Fix_Parent (Get_Node_Field_Union (Fix_Node, Desc.Offset));
            end if;
         end;
      end loop;
   end Fix_Parents;

   -----------------------------------
   -- Get_Comes_From_Source_Default --
   -----------------------------------

   function Get_Comes_From_Source_Default return Boolean is
   begin
      return Comes_From_Source_Default;
   end Get_Comes_From_Source_Default;

   ---------------
   -- Is_Entity --
   ---------------

   function Is_Entity (N : Node_Id) return Boolean is
   begin
      return Nkind (N) in N_Entity;
   end Is_Entity;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize is
      Dummy : Node_Id;
      pragma Warnings (Off, Dummy);

   begin
      --  Allocate Empty node

      Dummy := New_Node (N_Empty, No_Location);
      Set_Chars (Empty, No_Name);
      pragma Assert (Dummy = Empty);

      --  Allocate Error node, and set Error_Posted, since we certainly
      --  only generate an Error node if we do post some kind of error.

      Dummy := New_Node (N_Error, No_Location);
      Set_Chars (Error, Error_Name);
      Set_Error_Posted (Error, True);
      pragma Assert (Dummy = Error);
   end Initialize;

   --------------------------
   -- Is_Rewrite_Insertion --
   --------------------------

   function Is_Rewrite_Insertion (Node : Node_Id) return Boolean is
   begin
      return Rewrite_Ins (Node);
   end Is_Rewrite_Insertion;

   -----------------------------
   -- Is_Rewrite_Substitution --
   -----------------------------

   function Is_Rewrite_Substitution (Node : Node_Id) return Boolean is
   begin
      return Orig_Nodes.Table (Node) /= Node;
   end Is_Rewrite_Substitution;

   ------------------
   -- Last_Node_Id --
   ------------------

   function Last_Node_Id return Node_Id is
   begin
      return Node_Offsets.Last;
   end Last_Node_Id;

   ----------
   -- Lock --
   ----------

   procedure Lock is
   begin
      Orig_Nodes.Locked := True;
   end Lock;

   ----------------
   -- Lock_Nodes --
   ----------------

   procedure Lock_Nodes is
   begin
      pragma Assert (not Locked);
      Locked := True;
   end Lock_Nodes;

   -------------------------
   -- Mark_New_Ghost_Node --
   -------------------------

   procedure Mark_New_Ghost_Node (N : Node_Or_Entity_Id) is
   begin
      pragma Debug (Validate_Node_Write (N));

      --  The Ghost node is created within a Ghost region

      if Ghost_Mode = Check then
         if Nkind (N) in N_Entity then
            Set_Is_Checked_Ghost_Entity (N);
         end if;

      elsif Ghost_Mode = Ignore then
         if Nkind (N) in N_Entity then
            Set_Is_Ignored_Ghost_Entity (N);
         end if;

         Set_Is_Ignored_Ghost_Node (N);

         --  Record the ignored Ghost node or entity in order to eliminate it
         --  from the tree later.

         if Ignored_Ghost_Recording_Proc /= null then
            Ignored_Ghost_Recording_Proc.all (N);
         end if;
      end if;
   end Mark_New_Ghost_Node;

   ----------------------------
   -- Mark_Rewrite_Insertion --
   ----------------------------

   procedure Mark_Rewrite_Insertion (New_Node : Node_Id) is
   begin
      Set_Rewrite_Ins (New_Node);
   end Mark_Rewrite_Insertion;

   --------------
   -- New_Copy --
   --------------

   function New_Copy (Source : Node_Id) return Node_Id is
      pragma Debug (Validate_Node (Source));

      New_Id : Node_Id;
      S_Size : constant Field_Offset := Size_In_Slots_To_Alloc (Source);
   begin
      if Source <= Empty_Or_Error then
         return Source;
      end if;

      New_Id := Alloc_Node_Id;
      Node_Offsets.Table (New_Id) := Alloc_Slots (S_Size);
      Orig_Nodes.Append (New_Id);
      Copy_Slots (Source, New_Id);

      Set_Check_Actuals (New_Id, False);
      Set_Paren_Count_Of_Copy (Target => New_Id, Source => Source);
      pragma Assert (Original_Node (Node_Offsets.Last) = Node_Offsets.Last);

      Allocate_List_Tables (New_Id);
      Report (Target => New_Id, Source => Source);

      Set_In_List (New_Id, False);
      Set_Link (New_Id, Empty_List_Or_Node);

      --  If the original is marked as a rewrite insertion, then unmark the
      --  copy, since we inserted the original, not the copy.

      Set_Rewrite_Ins (New_Id, False);

      --  Clear Is_Overloaded since we cannot have semantic interpretations
      --  of this new node.

      if Nkind (Source) in N_Subexpr then
         Set_Is_Overloaded (New_Id, False);
      end if;

      --  Always clear Has_Aspects, the caller must take care of copying
      --  aspects if this is required for the particular situation.

      Set_Has_Aspects (New_Id, False);

      --  Mark the copy as Ghost depending on the current Ghost region

      Mark_New_Ghost_Node (New_Id);

      New_Node_Debugging_Output (New_Id);

      pragma Assert (New_Id /= Source);
      return New_Id;
   end New_Copy;

   ----------------
   -- New_Entity --
   ----------------

   function New_Entity
     (New_Node_Kind : Node_Kind;
      New_Sloc      : Source_Ptr) return Entity_Id
   is
      pragma Assert (New_Node_Kind in N_Entity);
      New_Id : constant Entity_Id := Allocate_New_Node (New_Node_Kind);
      pragma Assert (Original_Node (Node_Offsets.Last) = Node_Offsets.Last);
   begin
      --  If this is a node with a real location and we are generating
      --  source nodes, then reset Current_Error_Node. This is useful
      --  if we bomb during parsing to get a error location for the bomb.

      if  New_Sloc > No_Location and then Comes_From_Source_Default then
         Current_Error_Node := New_Id;
      end if;

      Set_Sloc (New_Id, New_Sloc);

      --  Mark the new entity as Ghost depending on the current Ghost region

      Mark_New_Ghost_Node (New_Id);

      New_Node_Debugging_Output (New_Id);

      return New_Id;
   end New_Entity;

   --------------
   -- New_Node --
   --------------

   function New_Node
     (New_Node_Kind : Node_Kind;
      New_Sloc      : Source_Ptr) return Node_Id
   is
      pragma Assert (New_Node_Kind not in N_Entity);
      New_Id : constant Node_Id := Allocate_New_Node (New_Node_Kind);
      pragma Assert (Original_Node (Node_Offsets.Last) = Node_Offsets.Last);
   begin
      Set_Sloc (New_Id, New_Sloc);

      --  If this is a node with a real location and we are generating source
      --  nodes, then reset Current_Error_Node. This is useful if we bomb
      --  during parsing to get an error location for the bomb.

      if Comes_From_Source_Default and then New_Sloc > No_Location then
         Current_Error_Node := New_Id;
      end if;

      --  Mark the new node as Ghost depending on the current Ghost region

      Mark_New_Ghost_Node (New_Id);

      New_Node_Debugging_Output (New_Id);

      return New_Id;
   end New_Node;

   --------
   -- No --
   --------

   function No (N : Node_Id) return Boolean is
   begin
      return N = Empty;
   end No;

   -------------------
   -- Nodes_Address --
   -------------------

   function Node_Offsets_Address return System.Address is
   begin
      return Node_Offsets.Table (First_Node_Id)'Address;
   end Node_Offsets_Address;

   Slot_Byte_Size : constant := 4;
   pragma Assert (Slot_Byte_Size * 8 = Slot'Size);

   function Slots_Address return System.Address is
      Extra : constant := Slots_Low_Bound * Slot_Byte_Size;
      --  Slots does not start at 0, so we need to subtract off the extra
      --  amount. We are returning Slots.Table (0)'Address, except that
      --  that component does not exist.
      use System.Storage_Elements;
   begin
      return Slots.Table (Slots_Low_Bound)'Address - Extra;
   end Slots_Address;

   -----------------------------------
   -- Approx_Num_Nodes_And_Entities --
   -----------------------------------

   function Approx_Num_Nodes_And_Entities return Nat is
   begin
      return Nat (Node_Offsets.Last - First_Node_Id);
   end Approx_Num_Nodes_And_Entities;

   -----------
   -- Off_0 --
   -----------

   function Off_0 (N : Node_Id) return Node_Offset is
      pragma Debug (Validate_Node (N));

      All_Node_Offsets : Node_Offsets.Table_Type renames
        Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
   begin
      return All_Node_Offsets (N);
   end Off_0;

   -----------
   -- Off_L --
   -----------

   function Off_L (N : Node_Id) return Node_Offset is
      pragma Debug (Validate_Node (N));

      All_Node_Offsets : Node_Offsets.Table_Type renames
        Node_Offsets.Table (Node_Offsets.First .. Node_Offsets.Last);
   begin
      return All_Node_Offsets (N) + Size_In_Slots (N) - 1;
   end Off_L;

   -------------------
   -- Original_Node --
   -------------------

   function Original_Node (Node : Node_Id) return Node_Id is
   begin
      pragma Debug (Validate_Node (Node));

      return Orig_Nodes.Table (Node);
   end Original_Node;

   -----------------
   -- Paren_Count --
   -----------------

   function Paren_Count (N : Node_Id) return Nat is
      pragma Debug (Validate_Node (N));

      C : constant Small_Paren_Count_Type := Small_Paren_Count (N);

   begin
      --  Value of 0,1,2 returned as is

      if C <= 2 then
         return C;

      --  Value of 3 means we search the table, and we must find an entry

      else
         for J in Paren_Counts.First .. Paren_Counts.Last loop
            if N = Paren_Counts.Table (J).Nod then
               return Paren_Counts.Table (J).Count;
            end if;
         end loop;

         raise Program_Error;
      end if;
   end Paren_Count;

   ------------
   -- Parent --
   ------------

   function Parent (N : Node_Id) return Node_Id is
   begin
      if Is_List_Member (N) then
         return Parent (List_Containing (N));
      else
         return Node_Id (Link (N));
      end if;
   end Parent;

   -------------
   -- Present --
   -------------

   function Present (N : Node_Id) return Boolean is
   begin
      return N /= Empty;
   end Present;

   --------------------------------
   -- Preserve_Comes_From_Source --
   --------------------------------

   procedure Preserve_Comes_From_Source (NewN, OldN : Node_Id) is
   begin
      Set_Comes_From_Source (NewN, Comes_From_Source (OldN));
   end Preserve_Comes_From_Source;

   ----------------------
   -- Print_Atree_Info --
   ----------------------

   procedure Print_Atree_Info (N : Node_Or_Entity_Id) is
      function Cast is new Unchecked_Conversion (Slot, Int);
   begin
      Write_Int (Int (Size_In_Slots (N)));
      Write_Str (" slots (");
      Write_Int (Int (Off_0 (N)));
      Write_Str (" .. ");
      Write_Int (Int (Off_L (N)));
      Write_Str ("):");

      for Off in Off_0 (N) .. Off_L (N) loop
         Write_Str (" ");
         Write_Int (Cast (Slots.Table (Off)));
      end loop;

      Write_Eol;
   end Print_Atree_Info;

   -------------------
   -- Relocate_Node --
   -------------------

   function Relocate_Node (Source : Node_Id) return Node_Id is
      New_Node : Node_Id;

   begin
      if No (Source) then
         return Empty;
      end if;

      New_Node := New_Copy (Source);
      Fix_Parents (Ref_Node => Source, Fix_Node => New_Node);

      --  We now set the parent of the new node to be the same as the parent of
      --  the source. Almost always this parent will be replaced by a new value
      --  when the relocated node is reattached to the tree, but by doing it
      --  now, we ensure that this node is not even temporarily disconnected
      --  from the tree. Note that this does not happen free, because in the
      --  list case, the parent does not get set.

      Set_Parent (New_Node, Parent (Source));

      --  If the node being relocated was a rewriting of some original node,
      --  then the relocated node has the same original node.

      if Is_Rewrite_Substitution (Source) then
         Set_Original_Node (New_Node, Original_Node (Source));
      end if;

      return New_Node;
   end Relocate_Node;

   -------------
   -- Replace --
   -------------

   procedure Replace (Old_Node, New_Node : Node_Id) is
      Old_Post : constant Boolean := Error_Posted (Old_Node);
      Old_HasA : constant Boolean := Has_Aspects (Old_Node);
      Old_CFS  : constant Boolean := Comes_From_Source (Old_Node);

      procedure Destroy_New_Node;
      --  Overwrite New_Node data with junk, for debugging purposes

      procedure Destroy_New_Node is
      begin
         Zero_Slots (New_Node);
         Node_Offsets.Table (New_Node) := Field_Offset'Base'Last;
      end Destroy_New_Node;

   begin
      New_Node_Debugging_Output (Old_Node);
      New_Node_Debugging_Output (New_Node);

      pragma Assert
        (not Is_Entity (Old_Node)
          and not Is_Entity (New_Node)
          and not In_List (New_Node)
          and Old_Node /= New_Node);

      --  Do copy, preserving link and in list status and required flags

      Copy_Node (Source => New_Node, Destination => Old_Node);
      Set_Comes_From_Source (Old_Node, Old_CFS);
      Set_Error_Posted      (Old_Node, Old_Post);
      Set_Has_Aspects       (Old_Node, Old_HasA);

      --  Fix parents of substituted node, since it has changed identity

      Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node);

      pragma Debug (Destroy_New_Node);

      --  Since we are doing a replace, we assume that the original node
      --  is intended to become the new replaced node. The call would be
      --  to Rewrite if there were an intention to save the original node.

      Set_Original_Node (Old_Node, Old_Node);

      --  Invoke the reporting procedure (if available)

      if Reporting_Proc /= null then
         Reporting_Proc.all (Target => Old_Node, Source => New_Node);
      end if;
   end Replace;

   ------------
   -- Report --
   ------------

   procedure Report (Target, Source : Node_Id) is
   begin
      if Reporting_Proc /= null then
         Reporting_Proc.all (Target, Source);
      end if;
   end Report;

   -------------
   -- Rewrite --
   -------------

   procedure Rewrite (Old_Node, New_Node : Node_Id) is
      Old_CA     : constant Boolean := Check_Actuals (Old_Node);
      Old_Is_IGN : constant Boolean := Is_Ignored_Ghost_Node (Old_Node);
      Old_Error_Posted : constant Boolean :=
                           Error_Posted (Old_Node);
      Old_Has_Aspects  : constant Boolean :=
                           Has_Aspects (Old_Node);

      Old_Must_Not_Freeze : constant Boolean :=
        (if Nkind (Old_Node) in N_Subexpr then Must_Not_Freeze (Old_Node)
         else False);
      Old_Paren_Count     : constant Nat :=
        (if Nkind (Old_Node) in N_Subexpr then Paren_Count (Old_Node) else 0);
      --  These fields are preserved in the new node only if the new node and
      --  the old node are both subexpression nodes. We might be changing Nkind
      --  (Old_Node) from not N_Subexpr to N_Subexpr, so we need a value
      --  (False/0) even if Old_Noed is not a N_Subexpr.

      --  Note: it is a violation of abstraction levels for Must_Not_Freeze
      --  to be referenced like this. ???

      Sav_Node : Node_Id;

   begin
      New_Node_Debugging_Output (Old_Node);
      New_Node_Debugging_Output (New_Node);

      pragma Assert
        (not Is_Entity (Old_Node)
          and not Is_Entity (New_Node)
          and not In_List (New_Node));

      --  Allocate a new node, to be used to preserve the original contents
      --  of the Old_Node, for possible later retrival by Original_Node and
      --  make an entry in the Orig_Nodes table. This is only done if we have
      --  not already rewritten the node, as indicated by an Orig_Nodes entry
      --  that does not reference the Old_Node.

      if Original_Node (Old_Node) = Old_Node then
         Sav_Node := New_Copy (Old_Node);
         Set_Original_Node (Sav_Node, Sav_Node);
         Set_Original_Node (Old_Node, Sav_Node);

         --  Both the old and new copies of the node will share the same list
         --  of aspect specifications if aspect specifications are present.

         if Old_Has_Aspects then
            Set_Aspect_Specifications
              (Sav_Node, Aspect_Specifications (Old_Node));
         end if;
      end if;

      --  Copy substitute node into place, preserving old fields as required

      Copy_Node (Source => New_Node, Destination => Old_Node);
      Set_Error_Posted (Old_Node, Old_Error_Posted);
      Set_Has_Aspects  (Old_Node, Old_Has_Aspects);

      Set_Check_Actuals (Old_Node, Old_CA);
      Set_Is_Ignored_Ghost_Node (Old_Node, Old_Is_IGN);

      if Nkind (New_Node) in N_Subexpr then
         Set_Paren_Count     (Old_Node, Old_Paren_Count);
         Set_Must_Not_Freeze (Old_Node, Old_Must_Not_Freeze);
      end if;

      Fix_Parents (Ref_Node => New_Node, Fix_Node => Old_Node);

      --  Invoke the reporting procedure (if available)

      if Reporting_Proc /= null then
         Reporting_Proc.all (Target => Old_Node, Source => New_Node);
      end if;

      --  Invoke the rewriting procedure (if available)

      if Rewriting_Proc /= null then
         Rewriting_Proc.all (Target => Old_Node, Source => New_Node);
      end if;
   end Rewrite;

   -----------------------------------
   -- Set_Comes_From_Source_Default --
   -----------------------------------

   procedure Set_Comes_From_Source_Default (Default : Boolean) is
   begin
      Comes_From_Source_Default := Default;
   end Set_Comes_From_Source_Default;

   --------------------------------------
   -- Set_Ignored_Ghost_Recording_Proc --
   --------------------------------------

   procedure Set_Ignored_Ghost_Recording_Proc
     (Proc : Ignored_Ghost_Record_Proc)
   is
   begin
      pragma Assert (Ignored_Ghost_Recording_Proc = null);
      Ignored_Ghost_Recording_Proc := Proc;
   end Set_Ignored_Ghost_Recording_Proc;

   -----------------------
   -- Set_Original_Node --
   -----------------------

   procedure Set_Original_Node (N : Node_Id; Val : Node_Id) is
   begin
      pragma Debug (Validate_Node_Write (N));

      Orig_Nodes.Table (N) := Val;
   end Set_Original_Node;

   ---------------------
   -- Set_Paren_Count --
   ---------------------

   procedure Set_Paren_Count (N : Node_Id; Val : Nat) is
   begin
      pragma Debug (Validate_Node_Write (N));
      pragma Assert (Nkind (N) in N_Subexpr);

      --  Value of 0,1,2 stored as is

      if Val <= 2 then
         Set_Small_Paren_Count (N, Val);

      --  Value of 3 or greater stores 3 in node and makes table entry

      else
         Set_Small_Paren_Count (N, 3);

         --  Search for existing table entry

         for J in Paren_Counts.First .. Paren_Counts.Last loop
            if N = Paren_Counts.Table (J).Nod then
               Paren_Counts.Table (J).Count := Val;
               return;
            end if;
         end loop;

         --  No existing table entry; make a new one

         Paren_Counts.Append ((Nod => N, Count => Val));
      end if;
   end Set_Paren_Count;

   -----------------------------
   -- Set_Paren_Count_Of_Copy --
   -----------------------------

   procedure Set_Paren_Count_Of_Copy (Target, Source : Node_Id) is
   begin
      --  We already copied the Small_Paren_Count. We need to update the
      --  Paren_Counts table only if greater than 2.

      if Nkind (Source) in N_Subexpr
        and then Small_Paren_Count (Source) = 3
      then
         Set_Paren_Count (Target, Paren_Count (Source));
      end if;

      pragma Assert (Paren_Count (Target) = Paren_Count (Source));
   end Set_Paren_Count_Of_Copy;

   ----------------
   -- Set_Parent --
   ----------------

   procedure Set_Parent (N : Node_Id; Val : Node_Id) is
   begin
      pragma Assert (not Locked);
      pragma Assert (not In_List (N));
      Set_Link (N, Union_Id (Val));
   end Set_Parent;

   ------------------------
   -- Set_Reporting_Proc --
   ------------------------

   procedure Set_Reporting_Proc (Proc : Report_Proc) is
   begin
      pragma Assert (Reporting_Proc = null);
      Reporting_Proc := Proc;
   end Set_Reporting_Proc;

   ------------------------
   -- Set_Rewriting_Proc --
   ------------------------

   procedure Set_Rewriting_Proc (Proc : Rewrite_Proc) is
   begin
      pragma Assert (Rewriting_Proc = null);
      Rewriting_Proc := Proc;
   end Set_Rewriting_Proc;

   function Size_In_Slots_To_Alloc (Kind : Node_Kind) return Field_Offset is
   begin
      return
        (if Kind in N_Entity then Einfo.Entities.Max_Entity_Size
         else Sinfo.Nodes.Size (Kind));
      --  Unfortunately, we don't know the Entity_Kind, so we have to use the
      --  max.
   end Size_In_Slots_To_Alloc;

   function Size_In_Slots_To_Alloc
     (N : Node_Or_Entity_Id) return Field_Offset is
   begin
      return Size_In_Slots_To_Alloc (Nkind (N));
   end Size_In_Slots_To_Alloc;

   function Size_In_Slots (N : Node_Or_Entity_Id) return Field_Offset is
   begin
      pragma Assert (Nkind (N) /= N_Unused_At_Start);
      return
        (if Nkind (N) in N_Entity then Einfo.Entities.Max_Entity_Size
         else Sinfo.Nodes.Size (Nkind (N)));
   end Size_In_Slots;

   -------------------
   -- Traverse_Func --
   -------------------

   function Traverse_Func (Node : Node_Id) return Traverse_Final_Result is
      pragma Debug (Validate_Node (Node));

      function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result;
      --  Fld is one of the Traversed fields of Nod, which is necessarily a
      --  Node_Id or List_Id. It is traversed, and the result is the result of
      --  this traversal.

      --------------------
      -- Traverse_Field --
      --------------------

      function Traverse_Field (Fld : Union_Id) return Traverse_Final_Result is
      begin
         if Fld /= Union_Id (Empty) then

            --  Descendant is a node

            if Fld in Node_Range then
               return Traverse_Func (Node_Id (Fld));

            --  Descendant is a list

            elsif Fld in List_Range then
               declare
                  Elmt : Node_Id := First (List_Id (Fld));
               begin
                  while Present (Elmt) loop
                     if Traverse_Func (Elmt) = Abandon then
                        return Abandon;
                     end if;

                     Next (Elmt);
                  end loop;
               end;

            else
               raise Program_Error;
            end if;
         end if;

         return OK;
      end Traverse_Field;

      Cur_Node : Node_Id := Node;

   --  Start of processing for Traverse_Func

   begin
      --  If the last field is a node, we eliminate the tail recursion by
      --  jumping back to this label. This is because concatenations are
      --  sometimes deeply nested, as in X1&X2&...&Xn. Gen_IL ensures that the
      --  Left_Opnd field of N_Op_Concat comes last in Traversed_Fields, so the
      --  tail recursion is eliminated in that case. This trick prevents us
      --  from running out of stack memory in that case. We don't bother
      --  eliminating the tail recursion if the last field is a list.
      --
      --  (To check, look in the body of Sinfo.Nodes, search for the Left_Opnd
      --  getter, and note the offset of Left_Opnd. Then look in the spec of
      --  Sinfo.Nodes, look at the Traversed_Fields table, search for the
      --  N_Op_Concat component. The offset of Left_Opnd should be the last
      --  component before the No_Field_Offset sentinels.)

      <<Tail_Recurse>>

      case Process (Cur_Node) is
         when Abandon =>
            return Abandon;

         when Skip =>
            return OK;

         when OK =>
            null;

         when OK_Orig =>
            Cur_Node := Original_Node (Cur_Node);
      end case;

      --  Check for empty Traversed_Fields before entering loop below, so the
      --  tail recursive step won't go past the end.

      declare
         Cur_Field : Offset_Array_Index := Traversed_Offset_Array'First;
         Offsets : Traversed_Offset_Array renames
           Traversed_Fields (Nkind (Cur_Node));

      begin
         if Offsets (Traversed_Offset_Array'First) /= No_Field_Offset then
            while Offsets (Cur_Field + 1) /= No_Field_Offset loop
               declare
                  F : constant Union_Id :=
                    Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field));

               begin
                  if Traverse_Field (F) = Abandon then
                     return Abandon;
                  end if;
               end;

               Cur_Field := Cur_Field + 1;
            end loop;

            declare
               F : constant Union_Id :=
                 Get_Node_Field_Union (Cur_Node, Offsets (Cur_Field));

            begin
               if F not in Node_Range then
                  if Traverse_Field (F) = Abandon then
                     return Abandon;
                  end if;

               elsif F /= Empty_List_Or_Node then
                  --  Here is the tail recursion step, we reset Cur_Node and
                  --  jump back to the start of the procedure, which has the
                  --  same semantic effect as a call.

                  Cur_Node := Node_Id (F);
                  goto Tail_Recurse;
               end if;
            end;
         end if;
      end;

      return OK;
   end Traverse_Func;

   -------------------
   -- Traverse_Proc --
   -------------------

   procedure Traverse_Proc (Node : Node_Id) is
      function Traverse is new Traverse_Func (Process);
      Discard : Traverse_Final_Result;
      pragma Warnings (Off, Discard);
   begin
      Discard := Traverse (Node);
   end Traverse_Proc;

   ------------
   -- Unlock --
   ------------

   procedure Unlock is
   begin
      Orig_Nodes.Locked := False;
   end Unlock;

   ------------------
   -- Unlock_Nodes --
   ------------------

   procedure Unlock_Nodes is
   begin
      pragma Assert (Locked);
      Locked := False;
   end Unlock_Nodes;

   ----------------
   -- Zero_Slots --
   ----------------

   Zero : constant Slot := 0;

   procedure Zero_Slots (F, L : Node_Offset) is
   begin
      Slots.Table (F .. L) := (others => Zero);
   end Zero_Slots;

   procedure Zero_Slots (N : Node_Or_Entity_Id) is
   begin
      Zero_Slots (Off_0 (N), Off_L (N));
   end Zero_Slots;

end Atree;