libadalang_tools_24.0.0_d864b5a8/src/tgen/tgen_rts/tgen-types-record_types.adb

------------------------------------------------------------------------------
--                                                                          --
--                                  TGen                                    --
--                                                                          --
--                       Copyright (C) 2022, AdaCore                        --
--                                                                          --
-- TGen  is  free software; you can redistribute it and/or modify it  under --
-- under  terms of  the  GNU General  Public License  as  published by  the --
-- Free  Software  Foundation;  either version 3, or  (at your option)  any --
-- later version. This software  is distributed in the hope that it will be --
-- useful but  WITHOUT  ANY  WARRANTY; without even the implied warranty of --
-- MERCHANTABILITY  or  FITNESS  FOR A PARTICULAR PURPOSE.                  --
--                                                                          --
-- As a special  exception  under  Section 7  of  GPL  version 3,  you are  --
-- granted additional  permissions described in the  GCC  Runtime  Library  --
-- Exception, version 3.1, as published by the Free Software Foundation.    --
--                                                                          --
-- You should have received a copy of the GNU General Public License and a  --
-- copy of the GCC Runtime Library Exception along with this program;  see  --
-- the files COPYING3 and COPYING.RUNTIME respectively.  If not, see        --
-- <http://www.gnu.org/licenses/>.                                          --
------------------------------------------------------------------------------

with Ada.Containers;        use Ada.Containers;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings;           use Ada.Strings;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Unchecked_Deallocation;

with TGen.Types.Array_Types; use TGen.Types.Array_Types;

package body TGen.Types.Record_Types is

   LF : constant String := [1 => ASCII.LF];

   Pad : constant Unbounded_String := 3 * ' ';

   function PP_Variant
     (Var : Variant_Part_Acc; Padding : Natural := 0) return Unbounded_String;

   procedure Fill_Components
     (Self :        Variant_Part; Constraints : Disc_Value_Map;
      Res  : in out Component_Maps.Map);
   --  Fill Res with the list of components in Self that are present given
   --  a map of discriminant constraints.

   -----------
   -- Image --
   -----------

   function Image (Self : Record_Typ) return String is
     (Image_Internal (Self, 0));

   --------------------
   -- Image_Internal --
   --------------------

   function Image_Internal
     (Self : Record_Typ; Padding : Natural := 0) return String
   is
      use Component_Maps;
      Str : Unbounded_String := To_Unbounded_String (Typ (Self).Image);
      Current_Component : Component_Maps.Cursor;
   begin
      if Self.Component_Types.Is_Empty then
         Str := Str & ": null record";
      else
         Str               := Str & ": record" & LF;
         Current_Component := Self.Component_Types.First;
         while Has_Element (Current_Component) loop
            Str :=
              Str & (Padding + 1) * Pad &
              (+Key (Current_Component)) & " : ";
            if Element (Current_Component).Get.Kind in Record_Typ_Range then
               Str :=
                 Str &
                 String'
                   (As_Record_Typ (Element (Current_Component)).Image_Internal
                      (Padding + 1)) &
                 LF;
            else
               Str := Str & Element (Current_Component).Get.Image & LF;
            end if;
            Next (Current_Component);
         end loop;
         Str := Str & "end record";
      end if;
      return To_String (Str);
   end Image_Internal;

   ---------------------
   -- Get_Diagnostics --
   ---------------------

   function Get_Diagnostics (Self : Record_Typ) return String is
      use Component_Maps;
   begin
      for Comp_Cur in Self.Component_Types.Iterate loop
         declare
            Diags : constant String := Element (Comp_Cur).Get.Get_Diagnostics;
         begin
            if Diags'Length > 0 then
               return Diags;
            end if;
         end;
      end loop;
      return "";
   end Get_Diagnostics;

   ------------
   -- Encode --
   ------------

   function Encode
     (Self : Record_Typ; Val : JSON_Value) return JSON_Value
   is
      use Component_Maps;
      Components : constant JSON_Value := Val.Get ("components");
   begin
      return Res : constant JSON_Value := Create_Object do
         for Cur in Self.Component_Types.Iterate loop
            declare
               Comp_Name : constant String := To_String (Key (Cur));
               Comp_Val  : constant JSON_Value := Components.Get (Comp_Name);
            begin
               Components.Set_Field
                 (Comp_Name, Element (Cur).Get.Encode (Comp_Val));
            end;
         end loop;
         Res.Set_Field ("components", Components);
      end return;
   end Encode;

   ------------------
   -- Free_Variant --
   ------------------

   procedure Free_Variant (Var : in out Variant_Part_Acc) is
      use Variant_Choice_Lists;
      procedure Free is new Ada.Unchecked_Deallocation
        (Variant_Part, Variant_Part_Acc);

      procedure Destroy_Var_Choice (Var_Choice : in out Variant_Choice);

      ------------------------
      -- Destroy_Var_Choice --
      ------------------------

      procedure Destroy_Var_Choice (Var_Choice : in out Variant_Choice) is
      begin
         if Var_Choice.Variant /= null then
            Free_Variant (Var_Choice.Variant);
         end if;
      end Destroy_Var_Choice;
   begin
      if Var /= null then
         declare
            Cur : Variant_Choice_Lists.Cursor := Var.Variant_Choices.First;
         begin
            while Has_Element (Cur) loop
               Var.Variant_Choices.Update_Element
               (Cur, Destroy_Var_Choice'Access);
               Next (Cur);
            end loop;
            Free (Var);
         end;
      end if;
   end Free_Variant;

   -------------------
   -- Clone_Variant --
   -------------------

   function Clone (Var : Variant_Part_Acc) return Variant_Part_Acc is
      Res : Variant_Part_Acc;
   begin
      if Var = null then
         return null;
      end if;
      Res            := new Variant_Part;
      Res.Discr_Name := Var.Discr_Name;
      for Choice of Var.Variant_Choices loop
         Res.Variant_Choices.Append
           (Variant_Choice'
              (Alt_Set      => Choice.Alt_Set.Copy,
               Components   => Choice.Components.Copy,
               Variant      => Clone (Choice.Variant)));
      end loop;
      return Res;
   end Clone;

   ---------------------------
   -- Constraints_Respected --
   ---------------------------

   function Constraints_Respected
     (Self : Discriminated_Record_Typ; Discriminant_Values : Disc_Value_Map)
      return Boolean
   is
      use Discriminant_Constraint_Maps;
      use Disc_Value_Maps;

      Constraint_Cur : Discriminant_Constraint_Maps.Cursor;
      Value_Cur      : Disc_Value_Maps.Cursor;
   begin
      if not Self.Constrained then
         return True;
      end if;

      Constraint_Cur := Self.Discriminant_Constraint.First;
      while Has_Element (Constraint_Cur) loop
         if Element (Constraint_Cur).Kind = Static then
            Value_Cur := Discriminant_Values.Find (Key (Constraint_Cur));
            if Has_Element (Value_Cur)
              and then Element (Value_Cur).Get
                /= Element (Constraint_Cur).Int_Val
            then
               return False;
            end if;
         end if;
         Next (Constraint_Cur);
      end loop;
      return True;
   end Constraints_Respected;

   ----------------
   -- Components --
   ----------------

   function Components
     (Self : Discriminated_Record_Typ; Discriminant_Values : Disc_Value_Map)
      return Component_Maps.Map
   is
      Res : Component_Maps.Map := Self.Component_Types.Copy;
   begin
      if Self.Variant /= null then
         Fill_Components (Self.Variant.all, Discriminant_Values, Res);
      end if;
      return Res;
   end Components;

   ---------------------
   -- Fill_Components --
   ---------------------

   procedure Fill_Components
     (Self        : Variant_Part;
      Constraints : Disc_Value_Map;
      Res         : in out Component_Maps.Map)
   is
      Disc_Val_Cur : constant Disc_Value_Maps.Cursor :=
        Constraints.Find (Self.Discr_Name);
      Discr_Val : Big_Int.Big_Integer;
   begin
      if Disc_Value_Maps.Has_Element (Disc_Val_Cur) then
         Discr_Val := Disc_Value_Maps.Element (Disc_Val_Cur).Get;
      end if;
      for Choice of Self.Variant_Choices loop
         declare
            Choice_Matches : Boolean := False;
            Comp_Cur : Component_Maps.Cursor := Choice.Components.First;
         begin
            for Interval_Set of Choice.Alt_Set loop
               if Discr_Val >= Interval_Set.Min
                 and then Discr_Val <= Interval_Set.Max
               then
                  Choice_Matches := True;
               end if;
            end loop;
            if Choice_Matches then
               while Component_Maps.Has_Element (Comp_Cur) loop
                  Res.Insert
                    (Component_Maps.Key (Comp_Cur),
                     Component_Maps.Element (Comp_Cur));
                  Component_Maps.Next (Comp_Cur);
               end loop;
               if Choice.Variant /= null then
                  Fill_Components (Choice.Variant.all, Constraints, Res);
               end if;
            end if;
            exit when Choice_Matches;
         end;
      end loop;
   end Fill_Components;

   ----------------
   -- PP_Variant --
   ----------------

   function PP_Variant
     (Var : Variant_Part_Acc; Padding : Natural := 0) return Unbounded_String
   is
      Res      : Unbounded_String := (Padding * Pad) & "case ";
      Comp_Cur : Component_Maps.Cursor;
   begin
      Res := Res & (+Var.Discr_Name) & " is" & LF;
      for Var_Choice of Var.Variant_Choices loop
         Res := Res & (Padding + 2) * Pad & "when ";
         for Alt of Var_Choice.Alt_Set loop
            Res :=
               Res & Big_Int.To_String (Alt.Min) & " .. "
               & Big_Int.To_String (Alt.Max);
            if Alt /= Var_Choice.Alt_Set.Last_Element then
               Res := Res & " | ";
            end if;
         end loop;
         Res := Res & " => " & LF;
         Comp_Cur := Var_Choice.Components.First;
         while Component_Maps.Has_Element (Comp_Cur) loop
            Res :=
              Res & (Padding + 3) * Pad &
              (+Component_Maps.Key (Comp_Cur)) & " : ";
            if Component_Maps.Element (Comp_Cur).Get.Kind in Record_Typ_Range
            then
               Res :=
                 Res &
                 String'
                   (As_Record_Typ (Component_Maps.Element (Comp_Cur))
                      .Image_Internal
                      (Padding + 3));
            else
               Res := Res & Component_Maps.Element (Comp_Cur).Get.Image;
            end if;
            Component_Maps.Next (Comp_Cur);
            Res := Res & LF;
         end loop;
         if Var_Choice.Variant /= null then
            Res := Res & PP_Variant (Var_Choice.Variant, Padding + 3);
         end if;
      end loop;
      Res := Res & (Padding + 1) * Pad & "end case" & LF;
      return Res;
   end PP_Variant;

   -----------
   -- Image --
   -----------

   function Image (Self : Discriminated_Record_Typ) return String is
     (Image_Internal (Self, 0));

   --------------------
   -- Image_Internal --
   --------------------

   function Image_Internal
     (Self : Discriminated_Record_Typ; Padding : Natural := 0) return String
   is
      use Component_Maps;
      Str : Unbounded_String := To_Unbounded_String (Typ (Self).Image);
      Current_Component : Component_Maps.Cursor;
   begin
      --  First display the discriminants in line
      Str :=
        Str & ": " & (if Self.Mutable then "" else "non ") &
        "mutable record (";
      Current_Component := Self.Discriminant_Types.First;
      loop
         exit when not Has_Element (Current_Component);
         Str :=
           Str & (+Key (Current_Component)) & ": " &
           Element (Current_Component).Get.Image;
         Next (Current_Component);
         exit when not Has_Element (Current_Component);
         Str := Str & "; ";
      end loop;
      Str := Str & ")" & LF;
      if Self.Component_Types.Is_Empty and Self.Variant = null then
         Str := Str & Padding * Pad & " no components" & LF;
      else
         if not Self.Component_Types.Is_Empty then
            Current_Component := Self.Component_Types.First;
            while Has_Element (Current_Component) loop
               Str :=
                 Str & (Padding + 1) * Pad &
                 (+Key (Current_Component)) & " : ";
               if Element (Current_Component).Get.Kind in Record_Typ_Range then
                  Str :=
                    Str &
                    String'
                      (As_Record_Typ (Element (Current_Component))
                         .Image_Internal
                         (Padding + 1));
               else
                  Str := Str & Element (Current_Component).Get.Image & LF;
               end if;
               Next (Current_Component);
            end loop;
         end if;

         if Self.Variant /= null then
            Str :=
              Str & (Padding + 1) * Pad &
              PP_Variant (Self.Variant, Padding + 1);
         end if;
      end if;
      Str := Str & "end record";
      return To_String (Str);
   end Image_Internal;

   ------------
   -- Encode --
   ------------

   function Encode
     (Self : Discriminated_Record_Typ; Val : JSON_Value) return JSON_Value
   is
      use Component_Maps;
      Disc_Values   : Disc_Value_Map;
      Comp_Map      : Component_Map;
      Discriminants : constant JSON_Value := Val.Get ("discriminants");
      Components    : constant JSON_Value := Val.Get ("components");
      Res           : constant JSON_Value := Create_Object;
   begin
      --  Encode the discriminants

      for Cur in Self.Discriminant_Types.Iterate loop
         declare
            Disc_Val : constant JSON_Value :=
              Discriminants.Get (To_String (Key (Cur)));
         begin
            Disc_Values.Insert (Key (Cur), Disc_Val);
            Discriminants.Set_Field
              (To_String (Key (Cur)), Element (Cur).Get.Encode (Disc_Val));
         end;
      end loop;
      Res.Set_Field ("discriminants", Discriminants);

      --  Encode the components

      Comp_Map := Self.Components (Disc_Values);
      for Cur in Comp_Map.Iterate loop
         Components.Set_Field
           (To_String (Key (Cur)),
            Element (Cur).Get.Encode
            (Components.Get (To_String (Key (Cur)))));
      end loop;
      Res.Set_Field ("components", Components);
      return Res;
   end Encode;

   ---------------------
   -- Get_Diagnostics --
   ---------------------

   function Get_Diagnostics (Self : Discriminated_Record_Typ) return String is
      Comp_Res : constant String := Record_Typ (Self).Get_Diagnostics;

      function Inspect_Variant (Var : Variant_Part_Acc) return String;
      --  Inspect the variant part for unsupported types, and return the first
      --  diagnostics found, if any.

      ---------------------
      -- Inspect_Variant --
      ---------------------

      function Inspect_Variant (Var : Variant_Part_Acc) return String is
      begin
         if Var = null then
            return "";
         end if;
         for Choice of Var.Variant_Choices loop
            for Comp of Choice.Components loop
               declare
                  Diags : constant String := Comp.Get.Get_Diagnostics;
               begin
                  if Diags'Length > 0 then
                     return Diags;
                  end if;
               end;
            end loop;
            declare
               Subvar_Res : constant String :=
                 Inspect_Variant (Choice.Variant);
            begin
               if Subvar_Res'Length > 0 then
                  return Subvar_Res;
               end if;
            end;
         end loop;
         return "";
      end Inspect_Variant;
   begin
      if Comp_Res'Length > 0 then
         return Comp_Res;
      end if;
      return Inspect_Variant (Self.Variant);
   end Get_Diagnostics;

   ------------------
   -- Supports_Gen --
   ------------------

   function Supports_Gen (Self : Discriminated_Record_Typ) return Boolean is

      function Inspect_Variant (Var : Variant_Part_Acc) return Boolean;
      --  Traverse the variant part tree to determine whether some type is not
      --  supported for generation.

      ---------------------
      -- Inspect_Variant --
      ---------------------

      function Inspect_Variant (Var : Variant_Part_Acc) return Boolean is
         Res : Boolean := True;
      begin
         if Var = null then
            return True;
         end if;
         for Choice of Var.Variant_Choices loop
            Res := (for all Cmp of Choice.Components => Cmp.Get.Supports_Gen);
            exit when not Res;
            Res := Inspect_Variant (Choice.Variant);
            exit when not Res;
         end loop;
         return Res;
      end Inspect_Variant;
   begin
      if not Record_Typ (Self).Supports_Gen then
         return False;
      end if;
      return Inspect_Variant (Self.Variant);
   end Supports_Gen;

   ------------------
   -- Free_Content --
   ------------------

   procedure Free_Content (Self : in out Discriminated_Record_Typ) is
   begin
      if Self.Variant /= null then
         Free_Variant (Self.Variant);
      end if;
   end Free_Content;

   function "="
     (L : Strategy_Type'Class;
      R : Strategy_Type'Class)
      return Boolean;

   function "="
     (L : Strategy_Type'Class;
      R : Strategy_Type'Class)
      return Boolean
   is
      pragma Unreferenced (L);
      pragma Unreferenced (R);
   begin
      return False;
   end "=";
   --  TODO: Implement this properly

   --  Static generation

   package Strategy_Maps is new Ada.Containers.Indefinite_Hashed_Maps
     (Key_Type        => Unbounded_String,
      Element_Type    => Strategy_Type'Class,
      Hash            => Ada.Strings.Unbounded.Hash,
      Equivalent_Keys => "=",
      "="             => "=");
   subtype Strategy_Map is Strategy_Maps.Map;

   type Record_Strategy_Type is new Strategy_Type with
      record
         T                : SP.Ref;
         Component_Strats : Strategy_Map;
         Generate : access function
           (T                : Record_Typ'Class;
            Component_Strats : in out Strategy_Map;
            Disc_Values      : Disc_Value_Map) return JSON_Value;
      end record;

   overriding function Generate
     (S           : in out Record_Strategy_Type;
      Disc_Values : Disc_Value_Map) return JSON_Value;

   --------------
   -- Generate --
   --------------

   function Generate
     (S           : in out Record_Strategy_Type;
      Disc_Values : Disc_Value_Map) return JSON_Value
   is
      T : constant Typ'Class := S.T.Get;
   begin
      return
        S.Generate (Record_Typ (T), S.Component_Strats, Disc_Values);
   end Generate;

   ------------------------
   -- Get_All_Components --
   ------------------------

   function Get_All_Components
     (Self : Discriminated_Record_Typ) return Component_Map
   is
      Res : Component_Map := Self.Component_Types;

      procedure Get_All_Components_Rec
        (Variant_Part : Variant_Part_Acc);

      procedure Get_All_Components_Rec
        (Variant_Part : Variant_Part_Acc)
      is
      begin
         if Variant_Part /= null then
            for Choice of Variant_Part.Variant_Choices loop
               for Comp_Cursor in Choice.Components.Iterate loop
                  declare
                     use Component_Maps;
                     Comp_Name : constant Unbounded_String :=
                       Key (Comp_Cursor);
                     Comp_Type : constant SP.Ref := Element (Comp_Cursor);
                  begin
                     Res.Insert (Comp_Name, Comp_Type);
                  end;
               end loop;
               Get_All_Components_Rec (Choice.Variant);
            end loop;
         end if;
      end Get_All_Components_Rec;
   begin
      Get_All_Components_Rec (Self.Variant);
      return Res;
   end Get_All_Components;

   function Generate_Record_Typ
     (Self        : Record_Typ'Class;
      Comp_Strats : in out Strategy_Map;
      Disc_Values : Disc_Value_Map) return JSON_Value;

   -------------------------
   -- Generate_Record_Typ --
   -------------------------

   function Generate_Record_Typ
     (Self        : Record_Typ'Class;
      Comp_Strats : in out Strategy_Map;
      Disc_Values : Disc_Value_Map) return JSON_Value
   is
      Res : constant JSON_Value := Create_Object;
      use Component_Maps;
   begin
      for Comp in Self.Component_Types.Iterate loop
         declare
            Comp_Name : constant Unbounded_String := Key (Comp);

            procedure Generate_Val
              (Comp_Name  : Unbounded_String;
               Comp_Strat : in out Strategy_Type'Class);

            procedure Generate_Val
              (Comp_Name  : Unbounded_String;
               Comp_Strat : in out Strategy_Type'Class) is
            begin
               Set_Field
                 (Val        => Res,
                  Field_Name => +Comp_Name,
                  Field      => Comp_Strat.Generate (Disc_Values));
            end Generate_Val;
         begin
            --  Generate a value

            Comp_Strats.Update_Element
              (Comp_Strats.Find (Comp_Name), Generate_Val'Access);
         end;
      end loop;
      return Res;
   end Generate_Record_Typ;

   function Pick_Samples_For_Disc
     (Variant : Variant_Part_Acc; Disc_Name : Unbounded_String)
      return Alternatives_Set_Vector;
   --  Returns a list of samples for the discriminant name, recurring through
   --  all the variant parts and checking whether the discriminant is present
   --  as a control value.
   --
   --  type A (I : Integer) is record with
   --     case I is
   --       when 0      => J : Integer;
   --       when others => null;
   --     end case;
   --  end record;
   --
   --  Would return there {[0:0]}, {[Integer'First:-1], [1:Integer'Last]} if
   --  we call it with Disc_Name = I.
   --
   --  If this record contains discriminated records whose discriminants are
   --  this record discriminants, we won't try to pick sample in this
   --  sub-record. TODO: we maybe should.

   ---------------------------
   -- Pick_Samples_For_Disc --
   ---------------------------

   function Pick_Samples_For_Disc
     (Variant : Variant_Part_Acc; Disc_Name : Unbounded_String)
      return Alternatives_Set_Vector
   is
      use Alternatives_Set_Vectors;

      Res : Alternatives_Set_Vector;
   begin
      if Variant = null then
         return Alternatives_Set_Vectors.Empty_Vector;
      end if;

      if Variant.all.Discr_Name = Disc_Name then
         for Choice of Variant.Variant_Choices loop
            Res.Append (Choice.Alt_Set);
         end loop;
      else
         for Choice of Variant.Variant_Choices loop
            Res.Append_Vector
              (Pick_Samples_For_Disc (Choice.Variant, Disc_Name));
         end loop;
      end if;

      return Res;
   end Pick_Samples_For_Disc;

   function Pick_Strat_For_Disc
     (Self      : Discriminated_Record_Typ;
      Disc_Name : Unbounded_String;
      Disc_Type : Discrete_Typ'Class)
      return Strategy_Type'Class;
   --  Return a generation strategy for the given discriminant

   -------------------------
   -- Pick_Strat_For_Disc --
   -------------------------

   function Pick_Strat_For_Disc
     (Self      : Discriminated_Record_Typ;
      Disc_Name : Unbounded_String;
      Disc_Type : Discrete_Typ'Class)
      return Strategy_Type'Class
   is
      Default_Strategy : constant Strategy_Type'Class :=
        Self.Discriminant_Types.Element (Disc_Name).Get.Default_Strategy;
      Samples          : Alternatives_Set_Vector;
   begin
      --  TODO: special strategies when discriminant also is an array index
      --  constraint, as we don't want to be purely random there, otherwise
      --  we would end up generating arrays that are too big.

      declare
         Found      : Boolean;
         Constraint : TGen.Types.Constraints.Index_Constraint;
      begin
         Self.Disc_Constrains_Array (Disc_Name, Found, Constraint);
         if Found then
            return Disc_Type.Generate_Array_Index_Constraint_Strategy
              (Disc_Name, Constraint);
         end if;
      end;

      Samples := Pick_Samples_For_Disc (Self.Variant, Disc_Name);

      --  If non empty Sample, make a sampling strategy

      if not Samples.Is_Empty then
         declare
            Sample_Strat      : Strategy_Acc;
            Dispatching_Strat : Dispatching_Strategy_Type;
         begin
            if Disc_Type in Discrete_Typ'Class then
               Sample_Strat :=
                 new Strategy_Type'Class'
                   (Disc_Type.Generate_Sampling_Strategy (Samples));
            else
               raise Program_Error
                 with "Unsupported discriminant type";
            end if;
            Dispatching_Strat.Bias := 0.5;
            Dispatching_Strat.S1   := Sample_Strat;
            Dispatching_Strat.S2   :=
              new Strategy_Type'Class'(Default_Strategy);
            return Dispatching_Strat;
         end;
      end if;

      return Default_Strategy;
   end Pick_Strat_For_Disc;

   --  Static strategy for record types

   type Nondisc_Record_Strategy_Type is
     new Record_Strategy_Type with null record;
   overriding function Generate
     (S            : in out Nondisc_Record_Strategy_Type;
      Disc_Context : Disc_Value_Map) return JSON_Value;

   --------------
   -- Generate --
   --------------

   function Generate
     (S            : in out Nondisc_Record_Strategy_Type;
      Disc_Context : Disc_Value_Map) return JSON_Value
   is
      Result : constant JSON_Value := Create_Object;
   begin
      --  Set the component values

      Set_Field
        (Result, "components",
         S.Generate (As_Record_Typ (S.T), S.Component_Strats, Disc_Context));
      return Result;
   end Generate;

   ----------------------
   -- Default_Strategy --
   ----------------------

   function Default_Strategy
     (Self : Nondiscriminated_Record_Typ) return Strategy_Type'Class
   is
      use Component_Maps;

      Strat : Nondisc_Record_Strategy_Type;
   begin
      SP.From_Element (Strat.T, Self'Unrestricted_Access);
      Strat.Generate := Generate_Record_Typ'Access;
      for Component in Self.Component_Types.Iterate loop
         declare
            Comp_Name : constant Unbounded_String := Key (Component);
         begin
            Strat.Component_Strats.Insert
              (Comp_Name, Element (Component).Get.Default_Strategy);
         end;
      end loop;
      return Strat;
   end Default_Strategy;

   --  Static strategy for discriminated record types

   type Disc_Record_Strategy_Type is
     new Record_Strategy_Type with
      record
         Disc_Strats : Strategy_Map;
      end record;

   overriding function Generate
     (S            : in out Disc_Record_Strategy_Type;
      Disc_Context : Disc_Value_Map) return JSON_Value;

   --------------
   -- Generate --
   --------------

   function Generate
     (S            : in out Disc_Record_Strategy_Type;
      Disc_Context : Disc_Value_Map) return JSON_Value
   is
      T           : constant Typ'Class := S.T.Get;
      Disc_Record : constant Discriminated_Record_Typ :=
        Discriminated_Record_Typ (T);

      use Disc_Value_Maps;

      Current_Context : Disc_Value_Map;
      --  This context holds the values for the discriminant of the record
      --  being generated.

      Discriminants : constant JSON_Value := Create_Object;
      Result        : constant JSON_Value := Create_Object;
   begin
      --  Start of by filling the discriminant context

      if Disc_Record.Constrained then

         --  If there are constraints, then we have to get their actual value
         --  from the Disc_Values.

         for Constraint_Cursor in Disc_Record.Discriminant_Constraint.Iterate
         loop
            declare
               use Discriminant_Constraint_Maps;

               Discriminant_Name : constant Unbounded_String :=
                 Key (Constraint_Cursor);
               Constraint        : constant Discrete_Constraint_Value :=
                 Element (Constraint_Cursor);
            begin
               pragma Assert (Constraint.Kind /= Non_Static);
               case Constraint.Kind is
                  when Static =>
                     Current_Context.Insert
                       (Discriminant_Name,
                        TGen.JSON.Create (Constraint.Int_Val));

                  when Discriminant =>

                     --  Make the correspondence here

                     Current_Context.Insert
                       (Discriminant_Name,
                        Disc_Context.Element (Constraint.Disc_Name));

                  when others =>
                     raise Program_Error
                       with "unsupported non static generation";
               end case;
            end;
         end loop;
      else
         for D_Strat_Cursor in S.Disc_Strats.Iterate loop
            declare
               use Strategy_Maps;

               procedure Generate_Val
                 (Disc_Name  : Unbounded_String;
                  Disc_Strat : in out Strategy_Type'Class);

               procedure Generate_Val
                 (Disc_Name  : Unbounded_String;
                  Disc_Strat : in out Strategy_Type'Class)
               is
               begin
                  Current_Context.Insert
                    (Disc_Name,
                     Disc_Strat.Generate (Current_Context));
               end Generate_Val;

            begin
               S.Disc_Strats.Update_Element
                 (D_Strat_Cursor, Generate_Val'Access);
            end;
         end loop;
      end if;

      --  Write the generated discriminant values; they are part of the
      --  generated record value.

      for Disc_Cursor in Current_Context.Iterate loop
         Set_Field
           (Val        => Discriminants,
            Field_Name => +Key (Disc_Cursor),
            Field      => Element (Disc_Cursor));
      end loop;
      Set_Field (Result, "discriminants", Discriminants);

      --  Now, generate values for the components

      declare
         Components : constant Component_Map :=
           Disc_Record.Components (Current_Context);
         R          : constant Record_Typ :=
           (Name                => Disc_Record.Name,
             Last_Comp_Unit_Idx => Disc_Record.Last_Comp_Unit_Idx,
            Component_Types     => Components,
            Static_Gen          => Disc_Record.Static_Gen,
            Fully_Private       => Disc_Record.Fully_Private);
      begin
         Set_Field
           (Result, "components",
            S.Generate (R, S.Component_Strats, Current_Context));
      end;
      return Result;
   end Generate;

   ----------------------
   -- Default_Strategy --
   ----------------------

   function Default_Strategy
     (Self : Discriminated_Record_Typ) return Strategy_Type'Class
   is
      Strat : Disc_Record_Strategy_Type;
      use Component_Maps;
   begin

      --  Pick the strategy for each discriminant

      for Disc in Self.Discriminant_Types.Iterate loop
         declare
            Disc_Name : constant Unbounded_String := Key (Disc);
         begin
            Strat.Disc_Strats.Insert
              (Disc_Name,
               Self.Pick_Strat_For_Disc
                 (Disc_Name, Discrete_Typ'Class
                      (Element (Disc).Unchecked_Get.all)));
         end;
      end loop;

      --  Generate the strategies for the record components

      SP.From_Element (Strat.T, Self'Unrestricted_Access);
      Strat.Generate := Generate_Record_Typ'Access;
      for Component in Self.Get_All_Components.Iterate loop
         declare
            Comp_Name : constant Unbounded_String := Key (Component);
         begin
            Strat.Component_Strats.Insert
              (Comp_Name, Element (Component).Get.Default_Strategy);
         end;
      end loop;

      return Strat;
   end Default_Strategy;

   procedure Disc_Constrains_Array
     (Component_Types     : Component_Map;
      Variant             : Variant_Part_Acc;
      Disc_Name           : Unbounded_String;
      Disc_Correspondence : UTT_Map;
      Found               : out Boolean;
      Constraint          : out TGen.Types.Constraints.Index_Constraint);
   --  Internal for the spec-declared Disc_Constrains_Array procedure.
   --  Component_Types are the currently analyzed component types, Variant is
   --  the currently analyzed variant, and Disc_Correspondence gives the
   --  current correspondence from sub-record discriminant names to top-level
   --  record discriminant names.

   ---------------------------
   -- Disc_Constrains_Array --
   ---------------------------

   procedure Disc_Constrains_Array
     (Component_Types     : Component_Map;
      Variant             : Variant_Part_Acc;
      Disc_Name           : Unbounded_String;
      Disc_Correspondence : UTT_Map;
      Found               : out Boolean;
      Constraint          : out TGen.Types.Constraints.Index_Constraint)
   is
      T_Ref           : SP.Ref;
      Constraints     : Constraint_Acc;
      Has_Constraints : Boolean;
   begin

      Found := False;
      Constraint := (Present => False);

      --  Check the components of the record

      for Component_Type of Component_Types loop

         Has_Constraints := False;
         T_Ref := Component_Type;

         if Component_Type.Get.Kind in Anonymous_Kind then
            Has_Constraints := True;
            Constraints :=
              As_Anonymous_Typ
                (Component_Type).Subtype_Constraints;
            T_Ref := As_Named_Typ (As_Anonymous_Typ (Component_Type));
         end if;

         if T_Ref.Get.Kind in Constrained_Array_Kind then
            declare
               T : constant Constrained_Array_Typ'Class :=
                 As_Constrained_Array_Typ (T_Ref);
            begin
               T.Is_Constrained_By_Variable (Disc_Name, Found, Constraint);

               if Found then

                  --  We got the constraint, but we still must translate it
                  --  according to the discriminant correspondence. The
                  --  constraint must be expressed in the terms of the
                  --  top-level record.

                  if Constraint.Present then
                     declare
                        CLB : constant Discrete_Constraint_Value :=
                          Constraint.Discrete_Range.Low_Bound;
                        CHB : constant Discrete_Constraint_Value :=
                          Constraint.Discrete_Range.High_Bound;
                     begin
                        if CLB.Kind = Discriminant then
                           Constraint.Discrete_Range.Low_Bound.Disc_Name :=
                             Disc_Correspondence.Element (CLB.Disc_Name);
                        end if;
                        if CHB.Kind = Discriminant then
                           Constraint.Discrete_Range.High_Bound.Disc_Name :=
                             Disc_Correspondence.Element (CHB.Disc_Name);
                        end if;
                     end;
                  end if;

                  --  The discriminant could constrain several arrays, but
                  --  there is no point taking them all into account. So stop
                  --  as soon as we found a match.

                  return;
               end if;
            end;
         end if;

         if T_Ref.Get.Kind in Disc_Record_Kind then

            --  If there are constraints, they are necessarily discriminant
            --  constraints. Records the discriminant correspondence to have
            --  an index constraint that can be applied to the top-level record
            --  at the end.

            if Has_Constraints then
               declare
                  Disc_Constraints : constant Discriminant_Constraint_Map :=
                    Discriminant_Constraints (Constraints.all).Constraint_Map;

                  New_Disc_Correspondence : UTT_Map;

                  Sub_Record : constant Discriminated_Record_Typ'Class :=
                    As_Discriminated_Record_Typ (T_Ref);

                  Inspect_Subrecord       : Boolean := False;
                  Correspondent_Disc_Name : Unbounded_String;
                  --  Whether the discriminant Disc_Name can affect the sub-
                  --  record, i.e. if it is propagated through a discriminant
                  --  constraint. If it is the case, Correspondent_Disc_Name
                  --  will hold the name of the discriminant that corresponds
                  --  to the original Disc_Name, in the nested sub-record.

               begin
                  for Constraint_Cursor in Disc_Constraints.Iterate loop
                     declare
                        Disc_Constrained : constant Unbounded_String :=
                          Discriminant_Constraint_Maps.Key (Constraint_Cursor);

                        Constraint : constant Discrete_Constraint_Value :=
                          Discriminant_Constraint_Maps.Element
                            (Constraint_Cursor);
                     begin

                        --  If the constraint is a discriminant constraint,
                        --  then we have a new correspondence.

                        if Constraint.Kind = Discriminant then
                           declare
                              Orig_Disc : constant Unbounded_String :=
                                Disc_Correspondence.Element
                                  (Constraint.Disc_Name);
                           begin
                              Inspect_Subrecord := True;
                              Correspondent_Disc_Name := Disc_Constrained;
                              New_Disc_Correspondence.Insert
                                (Disc_Constrained,
                                 Orig_Disc);
                           end;
                        end if;
                     end;
                  end loop;

                  if Inspect_Subrecord then
                     Disc_Constrains_Array
                       (Sub_Record.Component_Types,
                        Sub_Record.Variant,
                        Correspondent_Disc_Name,
                        New_Disc_Correspondence,
                        Found,
                        Constraint);
                  end if;
               end;

            else
               --  If we don't have any constraint, then we just drop it all,
               --  as none of the discriminant in the top level record will
               --  affect the types of a sub-record. Note that this is the case
               --  where the sub-record is mutable (i.e. has default values for
               --  discriminants), as we can't have an unconstrained value as
               --  a component of a record.

               null;
            end if;

         end if;
      end loop;

      --  Check the variant part

      if Variant /= null then
         for Variant_Choice of Variant.Variant_Choices loop
            Disc_Constrains_Array
              (Variant_Choice.Components,
               Variant_Choice.Variant,
               Disc_Name,
               Disc_Correspondence,
               Found,
               Constraint);
            if Found then
               return;
            end if;
         end loop;
      end if;
   end Disc_Constrains_Array;

   ---------------------------
   -- Disc_Constrains_Array --
   ---------------------------

   procedure Disc_Constrains_Array
     (Self       : Discriminated_Record_Typ;
      Disc_Name  : Unbounded_String;
      Found      : out Boolean;
      Constraint : out TGen.Types.Constraints.Index_Constraint)
   is
      Disc_Correspondence : UTT_Map;
   begin
      for Disc_Cursor in Self.Discriminant_Types.Iterate loop
         declare
            Disc_Name : constant Unbounded_String :=
              Component_Maps.Key (Disc_Cursor);
         begin
            Disc_Correspondence.Insert (Disc_Name, Disc_Name);
         end;
      end loop;

      Disc_Constrains_Array
        (Self.Component_Types,
         Self.Variant,
         Disc_Name,
         Disc_Correspondence,
         Found,
         Constraint);
   end Disc_Constrains_Array;

   ----------------------
   -- Default_Strategy --
   ----------------------

   function Default_Strategy
     (Self : Function_Typ) return Strategy_Type'Class
   is
      use Component_Maps;

      Strat : Nondisc_Record_Strategy_Type;
   begin
      SP.From_Element (Strat.T, Self'Unrestricted_Access);
      Strat.Generate := Generate_Record_Typ'Access;
      for Component in Self.Component_Types.Iterate loop
         declare
            Comp_Name : constant Unbounded_String := Key (Component);
         begin
            Strat.Component_Strats.Insert
              (Comp_Name, Element (Component).Get.Default_Strategy);
         end;
      end loop;
      return Strat;
   end Default_Strategy;

   -----------------
   -- Simple_Name --
   -----------------

   function Simple_Name (Self : Function_Typ) return String is
   begin
      return To_String (Unbounded_String
        (Self.Name.Element (Self.Name.Last_Index - 1)));
   end Simple_Name;

   ------------------------
   -- JSON_Test_Filename --
   ------------------------

   function JSON_Test_Filename (Self : Function_Typ) return String is
     (To_Filename (Self.Compilation_Unit_Name) & ".json");

end TGen.Types.Record_Types;