libadalang_tools_24.0.0_d864b5a8/src/tgen/tgen-types-translation.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.Exceptions;
with Ada.Text_IO; use Ada.Text_IO;

with GNATCOLL.GMP.Integers;

with Langkit_Support.Text; use Langkit_Support.Text;

with Libadalang.Analysis;  use Libadalang.Analysis;
with Libadalang.Common;    use Libadalang.Common;
with Libadalang.Expr_Eval; use Libadalang.Expr_Eval;

with Test.Common;

with TGen.LAL_Utils;             use TGen.LAL_Utils;
with TGen.Types.Array_Types;     use TGen.Types.Array_Types;
with TGen.Types.Constraints;     use TGen.Types.Constraints;
with TGen.Types.Discrete_Types;  use TGen.Types.Discrete_Types;
with TGen.Types.Enum_Types;      use TGen.Types.Enum_Types;
with TGen.Types.Int_Types;       use TGen.Types.Int_Types;
with TGen.Types.Real_Types;      use TGen.Types.Real_Types;
with TGen.Types.Record_Types;    use TGen.Types.Record_Types;
with TGen.Numerics;

package body TGen.Types.Translation is

   Translation_Error : exception;

   Non_Static_Error : exception;
   --  Exception raised when the translation of a type that should be static
   --  ends up not being static, due to missing bits in the static evaluator
   --  in LAL.

   function New_Eval_As_Int
     (Node : Expr'Class) return GNATCOLL.GMP.Integers.Big_Integer;
   --  Wrapper arround P_Eval_As_Int which raises Non_Static_Error when
   --  something that should be static turns out not to be due to a LAL
   --  limitation.

   Verbose_Diag : Boolean := False;
   package Text renames Langkit_Support.Text;

   function Get_From_Cache
     (FQN : Ada_Qualified_Name; T : out SP.Ref) return Boolean;
   --  Try to get a type named FQN from the cache. If the lookup is
   --  succesful, return True and set T to the cached translation.

   Cache_Hits : Natural := 0;
   Cache_Miss : Natural := 0;
   --  Stats for the cache

   type Local_Ada_Node_Arr is array (Positive range <>) of Ada_Node;
   --  Like Ada_Node_List, but that we can build ourselves

   function Translate_Internal
     (N                 : LAL.Base_Type_Decl;
      Verbose           : Boolean := False;
      Assume_Non_Static : Boolean := False) return Translation_Result;
   --  Actually translates the Base_Type_Decl. Translate is simply a
   --  memoization wrapper.
   --  If Assume_Non_Static is true, the the translated type will always be
   --  flaged as non static.

   function Translate_Int_Decl
     (Decl : Base_Type_Decl) return Translation_Result with
      Pre => Decl.P_Is_Int_Type;

   function Translate_Enum_Decl
     (Decl           : Base_Type_Decl;
      Root_Enum_Decl : Base_Type_Decl)
      return Translation_Result with
     Pre => Decl.P_Is_Static_Decl and then Decl.P_Is_Enum_Type;

   function Translate_Char_Decl
     (Decl : Base_Type_Decl) return Translation_Result with
     Pre => Decl.P_Is_Static_Decl and then Decl.P_Is_Enum_Type;

   function Translate_Float_Decl
     (Decl : Base_Type_Decl) return Translation_Result with
     Pre => Decl.P_Is_Static_Decl and then Decl.P_Is_Float_Type;

   function Translate_Ordinary_Fixed_Decl
     (Decl : Base_Type_Decl) return Translation_Result with
     Pre => Decl.P_Is_Static_Decl and then Decl.P_Is_Fixed_Point;

   function Translate_Decimal_Fixed_Decl
     (Decl : Base_Type_Decl) return Translation_Result with
     Pre => Decl.P_Is_Static_Decl and then Decl.P_Is_Fixed_Point;

   procedure Translate_Float_Range
     (Decl      :     Base_Type_Decl;
      Has_Range : out Boolean;
      Min, Max  : out Big_Reals.Big_Real);

   function Extract_Real_Range_Spec
     (Node : LAL.Constraint) return LAL.Range_Spec;
   --  Analyze contraint to determine if there are range constraints in Node,
   --  and if so, return the associated Range_Spec.

   function Translate_Real_Range_Spec
     (Node : LAL.Range_Spec) return Real_Range_Constraint;
   --  Translate a Range_Spec (Assumed to be of a real type)
   --  For practical reasons, the the range spec is an attribute reference to
   --  a real type for which no range is defined, this will default to
   --  Long_Float'First .. Long_Float'Last

   function Translate_Array_Decl
     (Decl : Base_Type_Decl) return Translation_Result with
     Pre => Decl.P_Root_Type.P_Full_View.P_Is_Array_Type;

   function Translate_Component_Decl_List
     (Decl_List : Ada_Node_List;
      Res       : in out Component_Maps.Map) return Unbounded_String;
      --  Translate the list of components of Decl into Res.
      --  If the returned string is empty then the results are valid, otherwise
      --  and error occured during translation and the contents of Res should
      --  not be used. The returned string contains the diagnostics of the
      --  translation

   function Translate_Variant_Part
     (Node          : LAL.Variant_Part;
      Discriminants : Component_Maps.Map)
     return Record_Types.Variant_Part with
     Pre => (not Node.Is_Null);

   procedure Subtract_Choice_From_Other
     (Others_Cur : Variant_Choice_Lists.Cursor;
      Choice     : Variant_Choice;
      List        : in out Variant_Choice_Lists.List);
   --  Subtract the Integer ranges that correspond to the matching alternatives
   --  in Choice.Alt_Set from the corresponding set in the variant
   --  choice denoted by Others_Cur.

   function Gather_Index_Constraint_Nodes
     (Decl_Or_Constraint : Ada_Node'Class;
      Num_Dims           : Positive) return Local_Ada_Node_Arr;
   --  Collect all the constraints on the indexes that are present in
   --  Decl_Or_Constraint, for which the kind should be one of Base_Type_Decl
   --  or Constraint. Num_Dims should match the number of constraints defined
   --  in Decl_Or_Constraint.

   function Translate_Record_Decl
     (Decl : Base_Type_Decl) return Translation_Result with
     Pre => Decl.P_Root_Type.P_Full_View.P_Is_Record_Type;

   procedure Apply_Record_Subtype_Decl
     (Decl : Subtype_Indication;
      Res  : in out Discriminated_Record_Typ) with
      Pre => Res.Constrained;
   --  Record the discriminant constraints of Decl in Res. For this, the
   --  type on which you want to apply constraints must be able to accept
   --  them.

   function Apply_Record_Derived_Type_Decl
     (Decl : Type_Decl'Class;
      From : in out Discriminated_Record_Typ)
      return Discriminated_Record_Typ with
      Pre => Kind (Decl.F_Type_Def) in Ada_Derived_Type_Def_Range
         and then From.Constrained;
   --  Apply the effects of the record type derivation defined in Decl.
   --  If any discriminant constraints are present, this filters out the
   --  incompatible shapes, and renames discriminant which correspond
   --  between the ancestor type and the child type.

   procedure Filter_Variant_Part
     (Variant       : in out Variant_Part_Acc;
      TL_Components : in out Component_Maps.Map;
      Constraints   : Discriminant_Constraint_Maps.Map;
      Renaming      : Discriminant_Constraint_Maps.Map);
   --  Filter the unreachable shapes of Variant based on the constraints in
   --  Constraints, and rename the variant part discriminant based on the
   --  mapping in Renaming.

   function Record_Constrained
     (Decl : Base_Type_Decl;
      Root : Base_Type_Decl) return Boolean;
   --  Returns True if Decl has discriminants constraints at some stage in the
   --  chain of subtype definitions / type derivations.

   function Eval_Discrete_Range
     (Rng : Discrete_Range)
     return TGen.Types.Constraints.Discrete_Range_Constraint;

   function Translate_Discrete_Range_Constraint
     (Node : LAL.Range_Constraint) return Discrete_Range_Constraint;
   --  Translate a range constraint that applies to a discrete type

   function Translate_Real_Constraints
     (Node : LAL.Constraint) return TGen.Types.Constraints.Constraint'Class;
   --  Translate constraints that apply to a real type. This can return
   --  either a Real_Range_Constraint or a Digits_Constraint.
   --  ??  Implement delta constraints and digits constraints for decimal fixed
   --  points.

   function Translate_Index_Constraints
     (Node     : LAL.Constraint;
      Num_Dims : Positive)
      return TGen.Types.Constraints.Index_Constraints;

   function Translate_Discriminant_Constraints
     (Node : LAL.Composite_Constraint)
     return TGen.Types.Constraints.Discriminant_Constraints;

   function Variant_Support_Static_Gen (Var : Variant_Part_Acc) return Boolean;

   function Var_Choice_Supports_Static_Gen
     (Choice : Variant_Choice) return Boolean;

   function "+" (Text : Text_Type) return Unbounded_String is (+(+Text));

   function "+" (Text : Unbounded_Text_Type) return Unbounded_String is
     (TGen.Types.Translation."+" (+Text));

   function Decl_Is_Fully_Private (N : Basic_Decl'Class) return Boolean;
   --  Return whether N is fully private, i.e. whether the first declaration of
   --  N is in a private part, and can't thus be used outside the private parts
   --  of its declaration unit or child units.

   --------------
   -- PP_Cache --
   --------------

   procedure PP_Cache is
      use Translation_Maps;
      Cache_Cur : Cursor := Translation_Cache.First;
   begin
      while Has_Element (Cache_Cur) loop
         Put_Line
           (To_Ada (Key (Cache_Cur))
            & " => " & Element (Cache_Cur).Get.Image);
         Next (Cache_Cur);
      end loop;
   end PP_Cache;

   --------------------
   -- Get_From_Cache --
   --------------------

   function Get_From_Cache
     (FQN : Ada_Qualified_Name; T : out SP.Ref) return Boolean
   is
      use Translation_Maps;
      Cache_Cur : constant Cursor := Translation_Cache.Find (FQN);
   begin
      --  If we have the type name in the cache, return it

      if Cache_Cur /= No_Element then
         Cache_Hits := Cache_Hits + 1;
         T := Element (Cache_Cur);
         return True;
      end if;

      Cache_Miss := Cache_Miss + 1;
      return False;
   end Get_From_Cache;

   ------------------------------------
   -- Var_Choice_Supports_Static_Gen --
   ------------------------------------

   function Var_Choice_Supports_Static_Gen
     (Choice : Variant_Choice) return Boolean is
     ((for all Comp_Ref of Choice.Components
         => Comp_Ref.Get.Supports_Static_Gen)
       and then Variant_Support_Static_Gen (Choice.Variant));

   --------------------------------
   -- Variant_Support_Static_Gen --
   --------------------------------

   function Variant_Support_Static_Gen (Var : Variant_Part_Acc) return Boolean
   is (Var = null
       or else (for all Choice of Var.all.Variant_Choices
                   => Var_Choice_Supports_Static_Gen (Choice)));

   ----------------------
   -- New_Eval_As_Int --
   ----------------------

   function New_Eval_As_Int
     (Node : Expr'Class) return GNATCOLL.GMP.Integers.Big_Integer
   is
   begin
      return Node.P_Eval_As_Int;
   exception
      when Exc : Property_Error =>
         declare
            Error_Msg : constant String :=
              Ada.Exceptions.Exception_Message (Exc);
         begin
            if Error_Msg'Length >= 9 and then Error_Msg (1 .. 9) = "Unhandled"
            then

               --  Quick and dirty heuristic: cases where LAL should be able
               --  to statically evaluate the expression but isn't able to have
               --  an exception message that starts with "Unhandled"

               raise Non_Static_Error with Error_Msg;
            else

               --  We still want the Property_Error to propagate when we are
               --  not using the static evaluator correctly

               raise;
            end if;
         end;
   end New_Eval_As_Int;

   ---------------------------
   -- Decl_Is_Fully_Private --
   ---------------------------

   function Decl_Is_Fully_Private (N : Basic_Decl'Class) return Boolean is
      First_Part : constant Basic_Decl := N.P_All_Parts (1);
      Sem_Parent : Ada_Node := First_Part.P_Semantic_Parent;
   begin
      --  Consider that N is fully private if there is a private part node
      --  among the chain of semantic parents of the first part of N, until we
      --  reach a library level package declaration.

      while not Sem_Parent.Is_Null
           and then
             not (Sem_Parent.Kind in Ada_Package_Decl_Range
                  and then Sem_Parent.Parent.Kind in Ada_Library_Item_Range)
      loop
         if Sem_Parent.Kind in Ada_Private_Part_Range then
            return True;
         end if;
         Sem_Parent := Sem_Parent.P_Semantic_Parent;
      end loop;
      return False;
   end Decl_Is_Fully_Private;

   ------------------------
   -- Translate_Int_Decl --
   ------------------------

   function Translate_Int_Decl
     (Decl : Base_Type_Decl) return Translation_Result
   is
      Rang : constant Discrete_Range := Decl.P_Discrete_Range;

      Max, Min : Big_Integer;
      --  Static evaluations of the bounds, if available

      Is_Actually_Static : Boolean := Decl.P_Is_Static_Decl;
      --  Sometimes LAL reports a declaration as static, but isn't able to
      --  evaluate the bounds of the type, we thus have to consider the type as
      --  non static. To do so we have no choice but to try to evaluate the
      --  bounds, and see if we get an exception.

      Is_Mode_Typ : constant Boolean :=
        Decl.P_Root_Type.P_Full_View.As_Concrete_Type_Decl.F_Type_Def.Kind
          in Ada_Mod_Int_Type_Def;
   begin
      if High_Bound (Rang).Is_Null then
         Is_Actually_Static := False;
      end if;
      if Is_Actually_Static then
         begin
            Max :=
              Big_Int.From_String (New_Eval_As_Int (High_Bound (Rang)).Image);
         exception
            when Non_Static_Error =>
               Max := Big_Int.To_Big_Integer (0);
               Is_Actually_Static := False;
         end;
      end if;

      if Is_Mode_Typ then
         --  ???modular subtypes can actually have a lower bound different than
         --  zero. We need to change the type representation to account for
         --  this.

         if Is_Actually_Static then
            return Res : Translation_Result (Success => True) do
               Res.Res.Set
                 (Mod_Int_Typ'(Is_Static => True,
                               Mod_Value => Max,
                               others    => <>));
            end return;
         else
            return Res : Translation_Result (Success => True) do
               Res.Res.Set
                 (Mod_Int_Typ'
                    (Is_Static => False,
                     others    => <>));
            end return;
         end if;
      end if;
      --  We are not dealing with a mod type, let's evaluate the low bound

      if Low_Bound (Rang).Is_Null then
         Is_Actually_Static := False;
      end if;
      if Is_Actually_Static then
         begin
            Min := Big_Int.From_String
               (New_Eval_As_Int (Low_Bound (Rang)).Image);
         exception
            when Non_Static_Error =>
               Min := Big_Int.To_Big_Integer (0);
               Is_Actually_Static := False;
         end;
      end if;
      if Is_Actually_Static then
         return Res : Translation_Result (Success => True) do
            Res.Res.Set
              (Signed_Int_Typ'(Is_Static          => True,
                               Range_Value        =>
                                 (Min => Min, Max => Max),
                              others              => <>));
         end return;
      else
         return Res : Translation_Result (Success => True) do
            Res.Res.Set
              (Signed_Int_Typ'
                 (Is_Static => False,
                  others    => <>));
         end return;
      end if;
   end Translate_Int_Decl;

   -------------------------
   -- Translate_Char_Decl --
   -------------------------

   function Translate_Char_Decl
     (Decl : Base_Type_Decl) return Translation_Result
   is
      Rang : constant Discrete_Range := Decl.P_Discrete_Range;
   begin

      if Is_Null (Low_Bound (Rang)) then
         return Res : Translation_Result (Success => True) do
            Res.Res.Set (Char_Typ'
                           (Is_Static => True,
                            Has_Range => False,
                            others    => <>));
         end return;
      else
         declare
            LB, HB : Discrete_Constraint_Value;
         begin
            if Low_Bound (Rang).P_Is_Static_Expr then
               LB :=
                 (Kind    => Static,
                  Int_Val => Big_Int.From_String
                    (New_Eval_As_Int (Low_Bound (Rang)).Image));
            else
               LB := (Kind => Non_Static, Text => +Low_Bound (Rang).Text);
            end if;
            if High_Bound (Rang).P_Is_Static_Expr then
               HB :=
                 (Kind    => Static,
                  Int_Val => Big_Int.From_String
                    (New_Eval_As_Int (High_Bound (Rang)).Image));
            else
               HB := (Kind => Non_Static, Text => +High_Bound (Rang).Text);
            end if;
            if LB.Kind = Static and then HB.Kind = Static then
               return Res : Translation_Result (Success => True) do
                  Res.Res.Set
                    (Char_Typ'(Is_Static   => True,
                               Has_Range   => True,
                               Range_Value =>
                                 (Low_Bound => LB, High_Bound => HB),
                               others       => <>));

               end return;
            else
               return Res : Translation_Result (Success => True) do
                  Res.Res.Set
                    (Char_Typ'(Is_Static   => False,
                               Has_Range   => True,
                               Range_Value =>
                                 (Low_Bound => LB, High_Bound => HB),
                               others      => <>));

               end return;
            end if;
         end;
      end if;
   end Translate_Char_Decl;

   -------------------------
   -- Translate_Enum_Decl --
   -------------------------

   function Translate_Enum_Decl
     (Decl           : Base_Type_Decl;
      Root_Enum_Decl : Base_Type_Decl) return Translation_Result
   is
      package Long_Long_Conversion is
        new Big_Int.Signed_Conversions (Int => Long_Long_Integer);

      use Long_Long_Conversion;

      Enum_Lits : Enum_Literal_Maps.Map;

      Index : Long_Long_Integer := 0;

      Rang : constant Discrete_Range := Decl.P_Discrete_Range;

      Max, Min : Long_Long_Integer;

   begin
      for Literal of Root_Enum_Decl.As_Type_Decl.F_Type_Def.As_Enum_Type_Def
        .F_Enum_Literals
      loop
         Enum_Lits.Insert
           (To_Big_Integer (Index), +Literal.F_Name.Text);
         Index := Index + 1;
      end loop;

      if not Is_Null (High_Bound (Rang))
        and then not Is_Null (Low_Bound (Rang))
      then
         Max :=
           Long_Long_Integer'Value (New_Eval_As_Int (High_Bound (Rang)).Image);
         Min :=
           Long_Long_Integer'Value (New_Eval_As_Int (Low_Bound (Rang)).Image);
         for Pos in From_Big_Integer (Enum_Lits.First_Key) .. Min - 1 loop
            Enum_Lits.Delete (To_Big_Integer (Pos));
         end loop;

         for Pos in Max + 1 .. From_Big_Integer (Enum_Lits.Last_Key) loop
            Enum_Lits.Delete (To_Big_Integer (Pos));
         end loop;
      end if;

      return Res : Translation_Result (Success => True) do
         Res.Res.Set
           (Other_Enum_Typ'(Is_Static => True,
                            Literals  => Enum_Lits,
                            others    => <>));
      end return;
   end Translate_Enum_Decl;

   --------------------------
   -- Translate_Float_Decl --
   --------------------------

   function Translate_Float_Decl
     (Decl : Base_Type_Decl) return Translation_Result
   is

      procedure Find_Digits
        (Decl : Base_Type_Decl; Digits_Value : out Natural);
      --  Determine the digits value of Decl.

      procedure Find_Digits (Decl : Base_Type_Decl; Digits_Value : out Natural)
      is
         Parent_Type : Subtype_Indication;
         Constraints : LAL.Digits_Constraint;
      begin
         if Decl = Decl.P_Root_Type then

            --  Decl is the root type decl, so we only need to translate the
            --  type definition.

            Digits_Value :=
              Natural'Value
                (New_Eval_As_Int
                  (Decl.As_Type_Decl.F_Type_Def.As_Floating_Point_Def
                  .F_Num_Digits).Image);
            return;
         end if;

         --  Decl is either a subtype decl or a derived type decl. Check if
         --  there are constraints associated with this decl.

         if Kind (Decl) in Ada_Subtype_Decl_Range then
            Parent_Type := Decl.As_Subtype_Decl.F_Subtype;

         elsif Kind (Decl.As_Type_Decl.F_Type_Def) in
                 Ada_Derived_Type_Def_Range
         then
            Parent_Type :=
              Decl.As_Type_Decl.F_Type_Def.As_Derived_Type_Def
                .F_Subtype_Indication;
         else
            raise Translation_Error with
              "Unexpected type decl for a floating point type declaration: "
              & Decl.Image;
         end if;
         if Is_Null (Parent_Type.F_Constraint) then

            --  If there aren't any constraints in the subtype indication,
            --  try to find the type properites on the referenced type.

            Find_Digits (Parent_Type.P_Designated_Type_Decl, Digits_Value);
         else

            --  Otherwise, analyze the type constraint
            case Kind (Parent_Type.F_Constraint) is
               when Ada_Range_Constraint_Range =>
                  Find_Digits
                    (Parent_Type.P_Designated_Type_Decl, Digits_Value);
                  return;
               when Ada_Digits_Constraint_Range =>
                  Constraints := Parent_Type.F_Constraint.As_Digits_Constraint;
                  Digits_Value :=
                    Natural'Value
                      (New_Eval_As_Int (Constraints.F_Digits).Image);
               when others =>
                  raise Translation_Error
                    with "Unexpected kind of" &
                    " constraint for float subtype indication: " &
                    Kind_Name (Constraints);
            end case;
         end if;
      end Find_Digits;

      Digits_Value : Natural := 0;
      Has_Range    : Boolean;
      Min, Max     : Big_Reals.Big_Real;

      Res : Translation_Result (Success => True);

   --  Start processing for Translate_Float_Decl

   begin
      Find_Digits (Decl, Digits_Value);
      Translate_Float_Range (Decl, Has_Range, Min, Max);
      if Has_Range then
         Res.Res.Set
           (Float_Typ'(Is_Static    => True,
                       Has_Range    => True,
                       Digits_Value => Digits_Value,
                       Range_Value  => (Min => Min, Max => Max),
                       others       => <>));
      else
         Res.Res.Set
           (Float_Typ'(Is_Static    => True,
                       Has_Range    => False,
                       Digits_Value => Digits_Value,
                       others       => <>));
      end if;
      return Res;
   exception
      when Exc : Translation_Error =>
         if Verbose_Diag then
            Put_Line
              ("Warning: could not determine static properties of" & " type" &
               Decl.Image & " : " & Ada.Exceptions.Exception_Message (Exc));
         end if;
         Res.Res.Set
           (Float_Typ'(Is_Static => False,
                       Has_Range => False,
                       others    => <>));
         return Res;
   end Translate_Float_Decl;

   -----------------------------------
   -- Translate_Ordinary_Fixed_Decl --
   -----------------------------------

   function Translate_Ordinary_Fixed_Decl
     (Decl : Base_Type_Decl) return Translation_Result
   is
      Min, Max    : Big_Real;
      Delta_Value : Big_Real;
      Has_Range   : Boolean;

      procedure Find_Delta
        (Decl : Base_Type_Decl; Delta_Value : out Big_Real);
      --  Travese the type hierachy from the bottom to find the inner most
      --  delta value of Decl.

      procedure Find_Delta
        (Decl : Base_Type_Decl; Delta_Value : out Big_Real)
      is
         Delta_Expr : Expr;
         --  Expr corresponding to the delta value, which will later be
         --  statically evaluated.

         Subtype_Ind : Subtype_Indication;
         --  Convininece variable to hold constraints to shorten then length of
         --  chained Libadalang dot calls.

         Subtype_Constraint : LAL.Constraint;
         --  Convininece variable to hold constraints to shorten then length of
         --  chained Libadalang dot calls.
      begin
         if Decl = Decl.P_Root_Type then

            --  First, the case where Decl is the root type, and thus we have a
            --  Ordinary_Fixed_Point_Def.

            pragma Assert
              (Kind (Decl.As_Type_Decl.F_Type_Def) in
               Ada_Ordinary_Fixed_Point_Def_Range);
            Delta_Expr :=
              Decl.As_Type_Decl.F_Type_Def.As_Ordinary_Fixed_Point_Def.F_Delta;

         elsif Kind (Decl) in Ada_Subtype_Decl_Range
           or else
           (Kind (Decl) in Ada_Type_Decl
            and then Kind (Decl.As_Type_Decl.F_Type_Def) =
              Ada_Derived_Type_Def)
         then

            --  Case of a subtype decl or derived type decl, look at the
            --  subtype indication for a constraint, or look at the delta of
            --  the parent subtype.

            if Kind (Decl) in Ada_Subtype_Decl_Range then
               Subtype_Ind := Decl.As_Subtype_Decl.F_Subtype;
            else
               Subtype_Ind :=
                 Decl.As_Type_Decl.F_Type_Def.As_Derived_Type_Def
                   .F_Subtype_Indication;
            end if;

            if Is_Null (Subtype_Ind.F_Constraint) then
               Find_Delta
                 (Subtype_Ind.F_Name.P_Name_Designated_Type, Delta_Value);
               return;
            end if;
            Subtype_Constraint := Subtype_Ind.F_Constraint;
            case Kind (Subtype_Constraint) is
               when Ada_Delta_Constraint_Range =>
                  Delta_Expr :=
                    Subtype_Constraint.As_Delta_Constraint.F_Digits;

               when Ada_Range_Constraint_Range =>

                  --  If we only have range constraints then look for the delta
                  --  value on the subtype designated by the subtype
                  --  indication.

                  Find_Delta
                    (Subtype_Ind.F_Name.P_Name_Designated_Type, Delta_Value);
                  return;

               when others =>
                  raise Translation_Error with
                    "Unexpected constraint kind for a ordinary fixed point"
                    & " subtype declaration: "
                    & Kind_Name (Subtype_Constraint);
            end case;
         else
            raise Translation_Error with
              "Unexpected base type decl for a ordinary fixed point decl: "
              & Image (Decl);
         end if;

         declare
            Delta_Eval : constant Eval_Result := Expr_Eval (Delta_Expr);
         begin
            if Delta_Eval.Kind /= Real then
               raise Translation_Error with "wrong eval type for delta value";
            end if;
            Delta_Value := TGen.Numerics.From_Universal_Image
              (Num => Delta_Eval.Real_Result.Numerator.Image,
               Den => Delta_Eval.Real_Result.Denominator.Image);
         end;
      end Find_Delta;

   --  Start of processing for Translate_Ordinary_Fixed_Decl

   begin
      Translate_Float_Range (Decl, Has_Range, Min, Max);
      pragma Assert (Has_Range);
      Find_Delta (Decl, Delta_Value);
      return Res : Translation_Result (Success => True) do
         Res.Res.Set
           (Ordinary_Fixed_Typ'(Is_Static   => True,
                                Delta_Value => Delta_Value,
                                Range_Value => (Min => Min, Max => Max),
                                others      => <>));
      end return;
   exception
      when Exc : Translation_Error =>

         --  In case of translation error, return a non-static type,
         --  but print the information if verbose diagnostics are required.
         if Verbose_Diag then
            Put_Line
              ("Warning: could not determine static properties of" & " type" &
               Decl.Image & " : " & Ada.Exceptions.Exception_Message (Exc));
         end if;
         return Res : Translation_Result (Success => True) do
            Res.Res.Set
              (Ordinary_Fixed_Typ'
                 (Is_Static => False,
                  others    => <>));
         end return;
   end Translate_Ordinary_Fixed_Decl;

   ----------------------------------
   -- Translate_Decimal_Fixed_Decl --
   ----------------------------------

   function Translate_Decimal_Fixed_Decl
     (Decl : Base_Type_Decl) return Translation_Result
   is
      Delta_Val  : Big_Real;
      Digits_Val : Natural;
      Has_Range  : Boolean;

      Range_Min, Range_Max : Big_Real;

      procedure Find_Digits (Decl : Base_Type_Decl; Digits_Val : out Natural);

      procedure Find_Delta (Decl : Base_Type_Decl; Delta_Val : out Big_Real);

      -----------------
      -- Find_Digits --
      -----------------

      procedure Find_Digits (Decl : Base_Type_Decl; Digits_Val : out Natural)
      is
         Parent_Subtype : Subtype_Indication;
      begin
         case Kind (Decl) is
            when Ada_Type_Decl =>
               if Kind (Decl.As_Type_Decl.F_Type_Def)
                    in Ada_Decimal_Fixed_Point_Def_Range
               then
                  --  Simply translate the Digits value
                  Digits_Val := Natural'Value
                    (New_Eval_As_Int
                       (Decl.As_Type_Decl.F_Type_Def.As_Decimal_Fixed_Point_Def
                        .F_Digits).Image);
                  return;
               elsif Kind (Decl.As_Type_Decl.F_Type_Def)
                       in Ada_Derived_Type_Def_Range
               then
                  Parent_Subtype :=
                     Decl.As_Type_Decl.F_Type_Def.As_Derived_Type_Def
                     .F_Subtype_Indication;
               else
                  raise Translation_Error with
                    "Unexpected kind for a type def translating a decimal"
                    & " fixed point type: "
                    & Kind_Name (Decl.As_Type_Decl.F_Type_Def);
               end if;
            when Ada_Subtype_Decl_Range =>
               Parent_Subtype := Decl.As_Subtype_Decl.F_Subtype;
            when others =>
               raise Translation_Error with
                 "unexpected kind for a decimal fixed point declaration:"
                 & Kind_Name (Decl);
         end case;
         if Is_Null (Parent_Subtype.F_Constraint)
           or else not (Kind (Parent_Subtype.F_Constraint)
                          in Ada_Digits_Constraint_Range)
         then
            Find_Digits (Parent_Subtype.P_Designated_Type_Decl, Digits_Val);
            return;
         end if;

         --  Constraints are a digits constraint from this point on
         Digits_Val := Natural'Value
           (New_Eval_As_Int
              (Parent_Subtype.F_Constraint.As_Digits_Constraint.F_Digits)
              .Image);
      end Find_Digits;

      ----------------
      -- Find_Delta --
      ----------------

      procedure Find_Delta (Decl : Base_Type_Decl; Delta_Val : out Big_Real)
      is
         --  There can be no delta constraints on a decimal fixed point type
         --  as per RM J.3 (5) so lets work on the type definition directly.

         Root_Typ : constant Type_Decl :=
           Decl.P_Root_Type.P_Full_View.As_Type_Decl;
         Eval_Res : constant Eval_Result :=
           Expr_Eval (Root_Typ.F_Type_Def.As_Decimal_Fixed_Point_Def.F_Delta);
      begin
         if Eval_Res.Kind /= Real then
            raise Translation_Error with
              "Evaluation of delta value for a decimal fixed point did not"
              & " return a real type";
         end if;
         Delta_Val := TGen.Numerics.From_Universal_Image
           (Num => Eval_Res.Real_Result.Numerator.Image,
            Den => Eval_Res.Real_Result.Denominator.Image);
      end Find_Delta;

   begin
      Find_Delta (Decl, Delta_Val);
      Find_Digits (Decl, Digits_Val);
      Translate_Float_Range (Decl, Has_Range, Range_Min, Range_Max);
      if Has_Range then
         return Res : Translation_Result (Success => True) do
            Res.Res.Set
            (Decimal_Fixed_Typ'(Is_Static    => True,
                                Has_Range    => True,
                                Digits_Value => Digits_Val,
                                Delta_Value  => Delta_Val,
                                Range_Value  =>
                                  (Min => Range_Min, Max => Range_Max),
                                others       => <>));
         end return;
      else
         return Res : Translation_Result (Success => True) do
            Res.Res.Set
            (Decimal_Fixed_Typ'(Is_Static    => True,
                                Has_Range    => False,
                                Digits_Value => Digits_Val,
                                Delta_Value  => Delta_Val,
                                others       => <>));
         end return;
      end if;
   end Translate_Decimal_Fixed_Decl;

   ---------------------------
   -- Translate_Float_Range --
   ---------------------------

   procedure Translate_Float_Range
     (Decl     :     Base_Type_Decl; Has_Range : out Boolean;
      Min, Max : out Big_Reals.Big_Real)
   is
      Root           : constant Type_Decl :=
        Decl.P_Root_Type.P_Full_View.As_Type_Decl;
      Parent_Type    : Subtype_Indication := No_Subtype_Indication;
      Range_Spec_Val : Range_Spec         := No_Range_Spec;
   begin
      if Decl = Root then

         --  Decl is the root type, it is a type decl

         case Kind (Decl.As_Type_Decl.F_Type_Def) is
            when Ada_Floating_Point_Def_Range =>
               Range_Spec_Val :=
                 Decl.As_Type_Decl.F_Type_Def.As_Floating_Point_Def.F_Range;
            when Ada_Ordinary_Fixed_Point_Def_Range =>
               Range_Spec_Val :=
                 Decl.As_Type_Decl.F_Type_Def.As_Ordinary_Fixed_Point_Def
                   .F_Range;
            when Ada_Decimal_Fixed_Point_Def_Range =>
               Range_Spec_Val :=
                 Decl.As_Type_Decl.F_Type_Def.As_Decimal_Fixed_Point_Def
                   .F_Range;
            when others =>
               raise Translation_Error
                 with "Expected Real type def for decl but got" &
                 Kind_Name (Decl.As_Type_Decl.F_Type_Def);
         end case;

         if Is_Null (Range_Spec_Val) then

            Has_Range := False;
            Min       := TGen.Types.Big_Zero_F;
            Max       := TGen.Types.Big_Zero_F;
            return;
         end if;

      else
         if Kind (Decl) in Ada_Type_Decl
           and then Kind (Decl.As_Type_Decl.F_Type_Def) in
                      Ada_Derived_Type_Def_Range
         then

            --  Decl is a derived type decl, look at the constraints in the
            --  subtype indication

            Parent_Type :=
              Decl.As_Type_Decl.F_Type_Def.As_Derived_Type_Def
                .F_Subtype_Indication;

         elsif Kind (Decl) in Ada_Subtype_Decl_Range then

            --  Same but for a subtype declaration

            Parent_Type := Decl.As_Subtype_Decl.F_Subtype;
         else
            raise Translation_Error
              with "Unexpected base type decl for a float type" &
              Kind_Name (Decl);
         end if;
         if Is_Null (Parent_Type.F_Constraint) then
            Translate_Float_Range
              (Parent_Type.P_Designated_Type_Decl, Has_Range, Min, Max);
            return;
         end if;

         --  Here we know the subtype indication had constraints.
         --  Now see if it has Range constraints and get it's range spec.
         --  Otherwise inspect the parent type to see if it has a range
         --  constraint defined.

         Range_Spec_Val := Extract_Real_Range_Spec (Parent_Type.F_Constraint);
         if Is_Null (Range_Spec_Val) then
            Translate_Float_Range
                  (Parent_Type.P_Designated_Type_Decl, Has_Range, Min, Max);
            return;
         end if;
      end if;

      declare
         Real_Rng : constant Real_Range_Constraint :=
           Translate_Real_Range_Spec (Range_Spec_Val);
      begin
         pragma Assert (Real_Rng.Low_Bound.Kind = Static
                        and then Real_Rng.High_Bound.Kind = Static);
         Has_Range := True;
         Min := Real_Rng.Low_Bound.Real_Val;
         Max := Real_Rng.High_Bound.Real_Val;
      end;
   end Translate_Float_Range;

   function Extract_Real_Range_Spec
     (Node : LAL.Constraint) return LAL.Range_Spec
   is
   begin
      case Kind (Node) is
         when Ada_Range_Constraint_Range =>
            return Node.As_Range_Constraint.F_Range;
         when Ada_Digits_Constraint_Range =>
            return Node.As_Digits_Constraint.F_Range;
         when Ada_Delta_Constraint_Range =>
            return Node.As_Delta_Constraint.F_Range;
         when others =>
            raise Translation_Error
               with "Unexpected kind of constraint for a real type " &
               Kind_Name (Node);
      end case;
   end Extract_Real_Range_Spec;

   function Translate_Real_Range_Spec
     (Node : LAL.Range_Spec) return Real_Range_Constraint
   is
      Min, Max : Big_Reals.Big_Real;
      Min_Text, Max_Text : Unbounded_Text_Type;
      Has_Range : Boolean;
      Min_Static, Max_Static : Boolean;
   begin
      case Kind (Node.F_Range) is

         --  According to RM 3.5 (3) a range constraint can only be of the form
         --  "Min .. Max" or "Name'Range", and assume we are analyzing a well
         --  formed AST.

         when Ada_Attribute_Ref_Range =>
            if Node.F_Range.P_Is_Static_Expr then
               Translate_Float_Range
                 (Node.F_Range.As_Attribute_Ref.F_Prefix
                  .P_Referenced_Decl
                  .As_Base_Type_Decl,
                  Has_Range, Min, Max);
               if not Has_Range then
                  Min := LF_Conversions.To_Big_Real (Long_Float'First);
                  Max := LF_Conversions.To_Big_Real (Long_Float'Last);
               end if;
               Min_Static := True;
               Max_Static := True;
            else
               Max_Text := +Node.Text;
               Min_Static := False;
               Max_Static := False;
            end if;

         when Ada_Bin_Op_Range =>
            if Node.F_Range.As_Bin_Op.F_Left.P_Is_Static_Expr then
               declare
                  Min_Eval : constant Eval_Result :=
                    Expr_Eval (Node.F_Range.As_Bin_Op.F_Left);
               begin
                  if Min_Eval.Kind /= Real then
                     raise Translation_Error with
                     "Wrong type of static eval for real range constraint.";
                  end if;
                  Min := TGen.Numerics.From_Universal_Image
                    (Num => Min_Eval.Real_Result.Numerator.Image,
                     Den => Min_Eval.Real_Result.Denominator.Image);
                  Min_Static := True;
               end;
            else
               Min_Text := +Node.F_Range.As_Bin_Op.F_Left.Text;
               Min_Static := False;
            end if;
            if Node.F_Range.As_Bin_Op.F_Right.P_Is_Static_Expr then
               declare
                  Max_Eval : constant Eval_Result :=
                    Expr_Eval (Node.F_Range.As_Bin_Op.F_Right);
               begin
                  if Max_Eval.Kind /= Real then
                     raise Translation_Error with
                     "Wrong type of static eval for real range constraint.";
                  end if;
                  Max := TGen.Numerics.From_Universal_Image
                    (Num => Max_Eval.Real_Result.Numerator.Image,
                     Den => Max_Eval.Real_Result.Denominator.Image);
                  Max_Static := True;
               end;
            else
               Max_Text := +Node.F_Range.As_Bin_Op.F_Right.Text;
               Max_Static := False;
            end if;

         when others =>
            raise Translation_Error
              with "Unexpected expression kind for real range constraint: " &
              Kind_Name (Node.F_Range);
      end case;

      if Min_Static and then Max_Static then
         return Real_Range_Constraint'
           (Low_Bound  => (Kind => Static, Real_Val => Min),
            High_Bound => (Kind => Static, Real_Val => Max));
      elsif Min_Static then
         return Real_Range_Constraint'
           (Low_Bound  => (Kind => Static, Real_Val => Min),
            High_Bound => (Kind => Non_Static, Text => +Max_Text));
      elsif Max_Static then
         return Real_Range_Constraint'
           (Low_Bound  => (Kind => Non_Static, Text => +Min_Text),
            High_Bound => (Kind => Static, Real_Val => Max));
      else
         return Real_Range_Constraint'
           (Low_Bound  => (Kind => Non_Static, Text => +Min_Text),
            High_Bound => (Kind => Non_Static, Text => +Max_Text));
      end if;

   end Translate_Real_Range_Spec;

   -----------------------------------
   -- Gather_Index_Constraint_Nodes --
   -----------------------------------

   function Gather_Index_Constraint_Nodes
     (Decl_Or_Constraint : Ada_Node'Class;
      Num_Dims          : Positive) return Local_Ada_Node_Arr
   is
      Res : Local_Ada_Node_Arr (1 .. Num_Dims);
      Current_Index : Positive := 1;
      Constraints : LAL.Constraint;
   begin
      case Kind (Decl_Or_Constraint) is
         when Ada_Type_Decl =>
            case Kind (Decl_Or_Constraint.As_Type_Decl.F_Type_Def) is
               when Ada_Array_Type_Def_Range =>
                  for Node of Decl_Or_Constraint.As_Type_Decl.F_Type_Def
                              .As_Array_Type_Def.F_Indices
                              .As_Constrained_Array_Indices.F_List
                  loop
                     Res (Current_Index) := Node.As_Ada_Node;
                     Current_Index := Current_Index + 1;
                  end loop;
                  return Res;
               when Ada_Derived_Type_Def_Range =>
                  Constraints := Decl_Or_Constraint.As_Type_Decl.F_Type_Def
                                 .As_Derived_Type_Def.F_Subtype_Indication
                                 .F_Constraint;
               when others => raise Translation_Error with
               "unexpected kind for index constraints in constrained array"
               & " type declaration: " & Kind_Name (Decl_Or_Constraint);
            end case;
         when Ada_Subtype_Decl_Range =>
            Constraints :=
              Decl_Or_Constraint.As_Subtype_Decl.F_Subtype.F_Constraint;
         when Ada_Constraint =>
            Constraints := Decl_Or_Constraint.As_Constraint;
         when others =>
            raise Translation_Error with
               "unexpected kind for index constraints: "
               & Kind_Name (Decl_Or_Constraint);
      end case;

      case Kind (Constraints) is
         when Ada_Composite_Constraint_Range =>
            for Node of Constraints.As_Composite_Constraint.F_Constraints loop
               Res (Current_Index) :=
                 Node.As_Composite_Constraint_Assoc.F_Constraint_Expr;
               Current_Index := Current_Index + 1;
            end loop;
         when others =>
            raise Translation_Error with
               "unexpected kind for index constraints: "
               & Kind_Name (Constraints);
      end case;
      return Res;
   end Gather_Index_Constraint_Nodes;

   --------------------------
   -- Translate_Array_Decl --
   --------------------------

   function Translate_Array_Decl
     (Decl : Base_Type_Decl) return Translation_Result
   is
      function Translate_Constrained
        (Decl : Base_Type_Decl) return Translation_Result;

      function Translate_Unconstrained
        (Def : Array_Type_Def) return Translation_Result;

      ---------------------------
      -- Translate_Constrained --
      ---------------------------

      function Translate_Constrained
        (Decl : Base_Type_Decl) return Translation_Result
      is
         Cmp_Typ_Def : constant Component_Def :=
            Decl.P_Root_Type.P_Full_View.As_Type_Decl.F_Type_Def
            .As_Array_Type_Def.F_Component_Type;
         Num_Indices : Natural := 0;
      begin
         --  Compute the number of indices

         while not Is_Null (Decl.P_Index_Type (Num_Indices)) loop
            Num_Indices := Num_Indices + 1;
         end loop;

         declare
            Constraint_Nodes : constant Local_Ada_Node_Arr :=
              Gather_Index_Constraint_Nodes (Decl.As_Ada_Node, Num_Indices);

            Res_Typ : Constrained_Array_Typ (Num_Indices);

            Component_Typ : constant Translation_Result :=
              Translate (Cmp_Typ_Def.F_Type_Expr, Verbose_Diag);
            --  This ignores any constraints on the element type that may
            --  appear in the component definition.

            Index_Typ                      : Base_Type_Decl;
            Has_Constraints                : Boolean;
            Range_Exp                      : Expr;
            Constraint_Min, Constraint_Max : Big_Integer;
            Min_Text, Max_Text             : Unbounded_Text_Type;
            Min_Static, Max_Static         : Boolean;

            Current_Index : Positive := 1;

            Failure_Reason : Unbounded_String;
         begin
            if not Component_Typ.Success then
               return (Success     => False,
                       Diagnostics => "Failed to translate component type of"
                                      & " array decl : "
                                      & Component_Typ.Diagnostics);
            end if;
            Res_Typ.Component_Type := Component_Typ.Res;

            for Constraint of Constraint_Nodes loop
               Index_Typ := Decl.P_Index_Type (Current_Index - 1);
               case Kind (Constraint) is
                  when Ada_Subtype_Indication_Range =>
                     if Is_Null
                           (Constraint.As_Subtype_Indication.F_Constraint)
                     then
                        Has_Constraints := False;
                     elsif Kind
                              (Constraint.As_Subtype_Indication.F_Constraint
                              .As_Range_Constraint.F_Range.F_Range)
                              in Ada_Attribute_Ref_Range | Ada_Bin_Op_Range
                     then
                        Range_Exp :=
                        Constraint.As_Subtype_Indication.F_Constraint
                                    .As_Range_Constraint.F_Range.F_Range;

                        Has_Constraints := True;
                     end if;
                  when Ada_Bin_Op_Range =>
                     Has_Constraints := True;
                     Range_Exp := Constraint.As_Expr;
                  when Ada_Attribute_Ref_Range =>
                     Has_Constraints := True;
                     Range_Exp := Constraint.As_Expr;
                  when others =>
                     Has_Constraints := False;
               end case;

               declare
                  Index_Trans : constant Translation_Result :=
                  Translate (Index_Typ, Verbose_Diag);
               begin
                  if not Index_Trans.Success then
                     Failure_Reason :=
                     "Failed to translate type of the index dimention"
                     & Current_Index'Image & ": " & Index_Trans.Diagnostics;
                     goto Failed_UC_Translation;
                  end if;
                  Res_Typ.Index_Types (Current_Index) := Index_Trans.Res;
               end;

               if Has_Constraints then
                  --  We should only encounter either a Bin Op (A .. B) or a
                  --  range attribute reference according to RM 3.5 (2).
                  begin
                     if Kind (Range_Exp) in Ada_Bin_Op_Range then
                        if Range_Exp.As_Bin_Op.F_Left.P_Is_Static_Expr then
                           Constraint_Min :=
                             Big_Int.From_String
                               (New_Eval_As_Int (Range_Exp.As_Bin_Op.F_Left)
                                .Image);
                           Min_Static := True;
                        else
                           Min_Static := False;
                           Min_Text := +Range_Exp.As_Bin_Op.F_Left.Text;
                        end if;
                        if Range_Exp.As_Bin_Op.F_Right.P_Is_Static_Expr then
                           Constraint_Max :=
                             Big_Int.From_String
                               (New_Eval_As_Int (Range_Exp.As_Bin_Op.F_Right)
                                .Image);
                           Max_Static := True;
                        else
                           Max_Static := False;
                           Max_Text := +Range_Exp.As_Bin_Op.F_Right.Text;
                        end if;
                     else
                        if Range_Exp.As_Attribute_Ref.F_Prefix
                           .P_Name_Designated_Type.P_Is_Static_Decl
                        then
                           Constraint_Min := Big_Int.From_String
                           (New_Eval_As_Int
                              (Low_Bound (Range_Exp.As_Attribute_Ref.F_Prefix
                              .P_Name_Designated_Type.P_Discrete_Range))
                              .Image);
                           Constraint_Max := Big_Int.From_String
                           (New_Eval_As_Int
                              (High_Bound (Range_Exp.As_Attribute_Ref.F_Prefix
                              .P_Name_Designated_Type.P_Discrete_Range))
                              .Image);
                           Min_Static := True;
                           Max_Static := True;
                        else
                           Min_Static := False;
                           Max_Static := False;
                           Max_Text := +Range_Exp.Text;
                        end if;
                     end if;
                  exception
                     when Non_Static_Error =>
                        Min_Static := False;
                        Max_Static := False;
                        Max_Text := +Range_Exp.Text;
                  end;
               end if;

               if not Has_Constraints then
                  Res_Typ.Index_Constraints (Current_Index) :=
                  (Present => False);
               elsif Max_Static and then not Min_Static then
                  Res_Typ.Index_Constraints (Current_Index) :=
                  (Present        => True,
                     Discrete_Range =>
                     (Low_Bound  => (Kind => Non_Static, Text => +Min_Text),
                      High_Bound => (Kind    => Static,
                                     Int_Val => Constraint_Min)));
               elsif Min_Static and not Max_Static then
                  Res_Typ.Index_Constraints (Current_Index) :=
                  (Present        => True,
                     Discrete_Range =>
                     (High_Bound  => (Kind => Non_Static, Text => +Max_Text),
                      Low_Bound   => (Kind    => Static,
                                      Int_Val => Constraint_Max)));
               elsif not (Max_Static and then Min_Static) then
                  Res_Typ.Index_Constraints (Current_Index) :=
                  (Present        => True,
                     Discrete_Range =>
                     (High_Bound  => (Kind => Non_Static, Text => +Max_Text),
                      Low_Bound   => (Kind => Non_Static, Text => +Min_Text)));
               else
                  Res_Typ.Index_Constraints (Current_Index) :=
                  (Present        => True,
                     Discrete_Range =>
                     (Low_Bound  => (Kind    => Static,
                                       Int_Val => Constraint_Min),
                        High_Bound => (Kind    => Static,
                                       Int_Val => Constraint_Max)));
               end if;
               Current_Index := Current_Index + 1;
            end loop;

            --  For constrained arrays, even if some index type is not
            --  statically known, as long as the matching index constraints
            --  are we should be able to generate values for this type.

            Res_Typ.Static_Gen :=
              Res_Typ.Component_Type.Get.Supports_Static_Gen
              and then (for all Idx in 1 .. Res_Typ.Num_Dims
                          => Static (Res_Typ.Index_Constraints (Idx)));

            return Res : Translation_Result (Success => True) do
               Res.Res.Set (Res_Typ);
            end return;

            <<Failed_UC_Translation>>
            return (Success => False, Diagnostics => Failure_Reason);
         end;
      end Translate_Constrained;

      -----------------------------
      -- Translate_Unconstrained --
      -----------------------------

      function Translate_Unconstrained
        (Def : Array_Type_Def) return Translation_Result
      is
         Indices_List : constant Unconstrained_Array_Index_List :=
           Def.F_Indices.As_Unconstrained_Array_Indices.F_Types;
         Num_Indices  : constant Positive := Indices_List.Last_Child_Index;

         Failure_Reason : Unbounded_String;

         Element_Type : constant Translation_Result :=
           Translate (Def.F_Component_Type.F_Type_Expr, Verbose_Diag);
           --  This ignores any constraints on the element type that may appear
           --  in the component definition.

         Current_Index_Type : Positive := 1;

         Res_Typ : Unconstrained_Array_Typ (Num_Indices);

      begin
         if not Element_Type.Success then
            return
              (Success     => False,
               Diagnostics => "Could not translate element type for array: "
                              & Element_Type.Diagnostics);
         end if;
         Res_Typ.Component_Type := Element_Type.Res;
         for Index of Indices_List loop
            declare
               Index_Type : constant Translation_Result :=
                 Translate
                   (Index.F_Subtype_Indication.As_Type_Expr, Verbose_Diag);
            begin
               if Index_Type.Success then
                  Res_Typ.Index_Types (Current_Index_Type) := Index_Type.Res;
                  Current_Index_Type := Current_Index_Type + 1;
               else
                  Failure_Reason := Index_Type.Diagnostics;
                  goto Failed_Translation;
               end if;
            end;
         end loop;
         Res_Typ.Static_Gen :=
           Res_Typ.Component_Type.Get.Supports_Static_Gen
           and then (for all Index_Ref of Res_Typ.Index_Types
                       => Index_Ref.Get.Supports_Static_Gen);

         return Res : Translation_Result (Success => True) do
            Res.Res.Set (Res_Typ);
         end return;

         <<Failed_Translation>>
         return (Success => False,
                 Diagnostics => "Failed to translate the type of the"
                                & Current_Index_Type'Image & "index dimension"
                                & ": " & Failure_Reason);

      end Translate_Unconstrained;

   --  Start of processing for Translate_Array_Decl

   begin
      case Kind (Decl) is
         when Ada_Subtype_Decl_Range =>
            if Is_Null (Decl.As_Subtype_Decl.F_Subtype.F_Constraint) then
               return Translate_Array_Decl
                 (Decl.As_Subtype_Decl.F_Subtype.P_Designated_Type_Decl);
            else
               return Translate_Constrained (Decl);
            end if;

         when Ada_Type_Decl =>

            if Kind (Decl.As_Type_Decl.F_Type_Def)
              in Ada_Derived_Type_Def_Range
            then
               if Is_Null (Decl.As_Type_Decl.F_Type_Def.As_Derived_Type_Def
                           .F_Subtype_Indication.F_Constraint)
               then
                  return Translate_Array_Decl
                    (Decl.As_Type_Decl.F_Type_Def.As_Derived_Type_Def
                     .F_Subtype_Indication.P_Designated_Type_Decl);
               else
                  return Translate_Constrained (Decl);
               end if;
            else
               case Kind (Decl.As_Type_Decl.F_Type_Def
                        .As_Array_Type_Def.F_Indices) is
                  when Ada_Constrained_Array_Indices_Range =>
                     return Translate_Constrained (Decl);

                  when Ada_Unconstrained_Array_Indices_Range =>
                     return Translate_Unconstrained
                     (Decl.As_Type_Decl.F_Type_Def.As_Array_Type_Def);

                  when others =>
                     return
                     (Success     => False,
                        Diagnostics =>
                         To_Unbounded_String
                            ("Unexpected array indices for array type def:")
                         & Kind_Name (Decl.As_Type_Decl.F_Type_Def
                                     .As_Array_Type_Def.F_Indices));
               end case;
            end if;

         when others =>
            return
              (Success     => False,
               Diagnostics =>
                  To_Unbounded_String
                     ("Unexpected base type decl kind for an array:")
                  & Kind_Name (Decl));
      end case;
   end Translate_Array_Decl;

   ------------------------
   -- Record_Constrained --
   ------------------------

   function Record_Constrained
      (Decl : Base_Type_Decl;
      Root : Base_Type_Decl) return Boolean
   is
      Ancestor_Type : Subtype_Indication;
   begin
      --  The original Decl of a record is not constrained.

      if Decl = Root then
         return False;
      end if;
      case Kind (Decl) is
         when Ada_Subtype_Decl_Range =>
            Ancestor_Type := Decl.As_Subtype_Decl.F_Subtype;
         when Ada_Type_Decl =>
            pragma Assert (Kind (Decl.As_Type_Decl.F_Type_Def)
                           in Ada_Derived_Type_Def_Range);
            Ancestor_Type := Decl.As_Type_Decl.F_Type_Def
                              .As_Derived_Type_Def.F_Subtype_Indication;
         when others =>
            return False;
            --  we should not be able to end up in here, but if we do,
            --  simply ignore the constraints.
      end case;

      if Is_Null (Ancestor_Type.F_Constraint) then
         return Record_Constrained
            (Ancestor_Type.P_Designated_Type_Decl, Root);
      else
         pragma Assert (Kind (Ancestor_Type.F_Constraint)
                           in Ada_Composite_Constraint_Range and
                          Ancestor_Type.F_Constraint
                               .As_Composite_Constraint
                               .P_Is_Discriminant_Constraint);
         return True;
      end if;
   end Record_Constrained;

   -------------------------------
   -- Apply_Record_Subtype_Decl --
   -------------------------------

   procedure Apply_Record_Subtype_Decl
      (Decl : Subtype_Indication;
       Res  : in out Discriminated_Record_Typ)
   is
   begin
      if Is_Null (Decl.F_Constraint) then
         return;
      end if;

      declare
         Const : TGen.Types.Constraints.Discriminant_Constraints :=
           Translate_Discriminant_Constraints
             (Decl.F_Constraint.As_Composite_Constraint);
      begin
         Res.Discriminant_Constraint.Move (Const.Constraint_Map);
      end;
   end Apply_Record_Subtype_Decl;

   -------------------------
   -- Filter_Variant_Part --
   -------------------------

   procedure Filter_Variant_Part
     (Variant       : in out Variant_Part_Acc;
      TL_Components : in out Component_Maps.Map;
      Constraints   : Discriminant_Constraint_Maps.Map;
      Renaming      : Discriminant_Constraint_Maps.Map)
   is
      use Variant_Choice_Lists;

      Choice_Cur : Cursor := Variant.Variant_Choices.First;

      procedure Filter_Variant_Choice (Var_Choice : in out Variant_Choice);

      procedure Delete_Nested_Variant (Var_Choice : in out Variant_Choice);

      ---------------------------
      -- Filter_Variant_Choice --
      ---------------------------

      procedure Filter_Variant_Choice (Var_Choice : in out Variant_Choice) is
      begin
         if Var_Choice.Variant /= null then
            Filter_Variant_Part
              (Var_Choice.Variant,
               Var_Choice.Components,
               Constraints,
               Renaming);
         end if;
      end Filter_Variant_Choice;

      ---------------------------
      -- Delete_Nested_Variant --
      ---------------------------

      procedure Delete_Nested_Variant (Var_Choice : in out Variant_Choice) is
      begin
         if Var_Choice.Variant /= null then
            Free_Variant (Var_Choice.Variant);
         end if;
      end Delete_Nested_Variant;

      Needs_Renaming : constant Boolean :=
        Renaming.Contains (Variant.Discr_Name);

   --  Start of processing for Filter_Variant_Part

   begin
      --  Rename the discriminant name associated with this variant part if it
      --  is in the renaming map.

      if Needs_Renaming then
         Variant.Discr_Name := Renaming.Element (Variant.Discr_Name).Disc_Name;
      end if;

      if Needs_Renaming
         or else not Constraints.Contains (Variant.Discr_Name)
         or else not (Constraints.Element (Variant.Discr_Name).Kind in Static)
      then

         --  If the discriminant name associated with this variant part is
         --  not in the constraint map, or is in the constraint map but the
         --  constraint is not static, simply update the eventual nested
         --  variant parts.

         while Has_Element (Choice_Cur) loop
            Variant.Variant_Choices.Update_Element
              (Choice_Cur, Filter_Variant_Choice'Access);
            Next (Choice_Cur);
         end loop;
      else

         --  Otherwise, check for each choice if it matches the constraint.
         --  If it does (there should only be one possible match), update
         --  the possibly nested variant parts, otherwise, free the possibly
         --  nested variant as the choice will be deleted.
         --  Once this is done, merge the components in the only remaining
         --  Choice to the top level components, and the the variant access
         --  to point to the nested variant part of the choice, if it exists.

         declare
            Discr_Val : constant Big_Integer :=
              Constraints.Element (Variant.Discr_Name).Int_Val;
            Match_Cur : Cursor := No_Element;
            Old_Variant : Variant_Part_Acc := Variant;

         begin
            while Has_Element (Choice_Cur) loop
               if not Has_Element (Match_Cur) then
                  for Alt of Element (Choice_Cur).Alt_Set loop
                     if Discr_Val >= Alt.Min and then Discr_Val <= Alt.Max then
                        Match_Cur := Choice_Cur;
                        Variant.Variant_Choices.Update_Element
                          (Choice_Cur, Filter_Variant_Choice'Access);
                     end if;
                  end loop;
               end if;
               if not Has_Element (Match_Cur) then
                  Variant.Variant_Choices.Update_Element
                    (Choice_Cur, Delete_Nested_Variant'Access);
               end if;
               Next (Choice_Cur);
            end loop;
            declare
               Match_Choice : constant Variant_Choice := Element (Match_Cur);
               Comp_Cur : Component_Maps.Cursor :=
                 Match_Choice.Components.First;

               procedure Set_Null (Var_Choice : in out Variant_Choice);

               procedure Set_Null (Var_Choice : in out Variant_Choice) is
               begin
                  Var_Choice.Variant := null;
               end Set_Null;
            begin
               while Component_Maps.Has_Element (Comp_Cur) loop
                  TL_Components.Insert
                    (Component_Maps.Key (Comp_Cur),
                     Component_Maps.Element (Comp_Cur));
                  Component_Maps.Next (Comp_Cur);
               end loop;
               if Match_Choice.Variant /= null then
                  Variant := Match_Choice.Variant;
                  Old_Variant.Variant_Choices.Update_Element
                     (Match_Cur, Set_Null'Access);
               else
                  Variant := null;
               end if;
               Free_Variant (Old_Variant);
            end;
         end;
      end if;
   end Filter_Variant_Part;

   ------------------------------------
   -- Apply_Record_Derived_Type_Decl --
   ------------------------------------

   function Apply_Record_Derived_Type_Decl
     (Decl : Type_Decl'Class;
      From : in out Discriminated_Record_Typ) return Discriminated_Record_Typ
   is

      use Discriminant_Constraint_Maps;

      Constraints_Map : Discriminant_Constraint_Maps.Map;
      Discr_Renaming_Map : Discriminant_Constraint_Maps.Map;
      Constraint_Cur : Cursor;
   begin
      --  There are three cases here:
      --  1. There is no known discriminant part, and no discriminant
      --     constraints. In that case, simply forward the type as is, with
      --     all of its discriminants and constraints
      --
      --  2. There is no known discriminant part, but we have a set of
      --     discriminant constraints. In that case, The type should become
      --     a non discriminated record type. We don't do this here, as we
      --     may have non-static constraints which prevent us from
      --     determining the actual components of the record, so we keep
      --     a Discriminated record type, but we'll prune the incompatible
      --     shapes as best as we can.
      --
      --  3. We have a known discriminant part and discriminant constraints,
      --     so the resulting type is a non constrained discriminated record
      --     type, but as with the previous case, some of the constraints
      --     may not be static, so we'll prune the incompatible shapes as
      --     best as possible.
      --
      --  Case 2 and 3 will be handled together given that we do not
      --  change the type to undiscriminated/nonconstrained_record_typ.
      --
      --  There cannot be a case where we have a known discriminant part but
      --  no discriminant constraints as we do not deal with tagged types.

      --  Case 1:

      if Is_Null (Decl.F_Type_Def.As_Derived_Type_Def.F_Subtype_Indication
                  .F_Constraint)
      then
         return From;
      end if;

      --  Case 2 & 3:

      --  First build a discriminant constraint map to filter out
      --  the unachievable shapes.

      return New_Typ : Discriminated_Record_Typ (Constrained => True) do
         New_Typ.Mutable :=
           not Is_Null (Decl.F_Discriminants)
           and then not Is_Null
             (Decl.F_Discriminants.As_Known_Discriminant_Part.F_Discr_Specs
              .First_Child.As_Discriminant_Spec.F_Default_Expr);

         for Pair of Decl.F_Type_Def.As_Derived_Type_Def
                        .F_Subtype_Indication.F_Constraint
                        .As_Composite_Constraint.F_Constraints
                        .P_Zip_With_Params
         loop
            if Kind (Actual (Pair)) in Ada_Name
               and then not Is_Null (Actual (Pair).As_Name
                                     .P_Referenced_Defining_Name)
               and then Kind (Actual (Pair).As_Name
                              .P_Referenced_Defining_Name.Parent.Parent) in
                        Ada_Discriminant_Spec_Range
            then
               --  Case of a Discriminant correspondence

               Discr_Renaming_Map.Insert
                 (Key      => +Param (Pair).As_Defining_Name.Text,
                  New_Item =>
                    (Kind          => Discriminant,
                     Disc_Name     => +Actual (Pair).As_Name
                                      .P_Referenced_Defining_Name.Text));
            elsif Actual (Pair).P_Is_Static_Expr
            then
               begin
                  --  Static value in the discriminant constraint
                  Constraints_Map.Insert
                  (Key      => +Param (Pair).As_Defining_Name.Text,
                     New_Item =>
                     (Kind    => Static,
                        Int_Val => Big_Int.From_String
                                    (New_Eval_As_Int (Actual (Pair)).Image)));
               exception
                  when Non_Static_Error =>
                     Constraints_Map.Insert
                       (Key      => +Param (Pair).As_Defining_Name.Text,
                        New_Item => (Kind => Non_Static,
                                     Text => +Actual (Pair).Text));
               end;
            else
               --  Non static value

               Constraints_Map.Insert
                 (Key      => +Param (Pair).As_Defining_Name.Text,
                  New_Item => (Kind => Non_Static,
                               Text => +Actual (Pair).Text));
            end if;
         end loop;

         --  Copy over the components that are always present

         New_Typ.Component_Types.Move (From.Component_Types);

         --  Then filter the variant part tree to remove any unreachable shape

         if From.Variant /= null then
            New_Typ.Variant := From.Variant;
            Filter_Variant_Part
              (New_Typ.Variant,
               New_Typ.Component_Types,
               Constraints_Map,
               Discr_Renaming_Map);

         end if;

         --  Fill out discriminant types

         Constraint_Cur := Discr_Renaming_Map.First;
         while Has_Element (Constraint_Cur) loop
            if Element (Constraint_Cur).Kind = Discriminant then
               New_Typ.Discriminant_Types.Insert
                  (Key     => Element (Constraint_Cur).Disc_Name,
                   New_Item => From.Discriminant_Types.Element
                                 (Key (Constraint_Cur)));
               Next (Constraint_Cur);
            end if;
         end loop;

         --  Then the non static constraints
         --  We also need to copy the corresponding discriminant type.

         Constraint_Cur := Constraints_Map.First;
         while Has_Element (Constraint_Cur) loop
            if Element (Constraint_Cur).Kind = Non_Static then
               New_Typ.Discriminant_Constraint.Insert
                  (Key (Constraint_Cur), Element (Constraint_Cur));
               New_Typ.Discriminant_Types.Insert
                  (Key     =>  Key (Constraint_Cur),
                   New_Item => From.Discriminant_Types.Element
                                 (Key (Constraint_Cur)));
            end if;
            Next (Constraint_Cur);
         end loop;
         New_Typ.Name := From.Name;
         New_Typ.Last_Comp_Unit_Idx := From.Last_Comp_Unit_Idx;
      end return;
   end Apply_Record_Derived_Type_Decl;

   --------------------------------
   -- Subtract_Choice_From_Other --
   --------------------------------

   procedure Subtract_Choice_From_Other
     (Others_Cur : Variant_Choice_Lists.Cursor;
      Choice     : Variant_Choice;
      List       : in out Variant_Choice_Lists.List)
   is
      use Alternatives_Sets;
      New_Set : Alternatives_Set;
      Cur_Alt : Cursor := Choice.Alt_Set.First;
      Cur_Others_Segment : Cursor;

      type Subtraction_Result is array (Positive range <>) of Int_Range;

      procedure Update_Set (Other_Var : in out Variant_Choice);

      procedure Get_Set (Other_Var : in out Variant_Choice);

      function Overlap (L, R : Int_Range) return Boolean;

      function "-" (L : Int_Range; R : Int_Range) return Subtraction_Result;

      -------------
      -- Get_Set --
      -------------

      procedure Get_Set (Other_Var : in out Variant_Choice) is
      begin
         New_Set.Move (Other_Var.Alt_Set);
      end Get_Set;

      ----------------
      -- Update_Set --
      ----------------

      procedure Update_Set
        (Other_Var : in out Variant_Choice)
      is
      begin
         Other_Var.Alt_Set.Move (New_Set);
      end Update_Set;

      -------------
      -- Overlap --
      -------------

      function Overlap (L, R : Int_Range) return Boolean is
      begin
         return R.Min <= L.Max and then L.Min <= R.Max;
      end Overlap;

      ---------
      -- "-" --
      ---------

      function "-" (L : Int_Range; R : Int_Range) return Subtraction_Result is
         One : constant Big_Integer := To_Big_Integer (1);
      begin
         if not Overlap (L, R) then
            return [1 => L];
         elsif R.Min <= L.Min  and then L.Max <= R.Max then
            return [1 .. 0 => <>];
         elsif L.Min < R.Min
              and then R.Min <= L.Max
              and then L.Max <= R.Max
         then
            return [1 => (Min => L.Min, Max => R.Min - One)];
         elsif R.Min <= L.Min
              and then L.Min <= R.Max
              and then R.Max < L.Max
         then
            return [1 => (Min => R.Max + One, Max => L.Max)];
         else
            return [1 => (Min => L.Min, Max => R.Min - One),
                    2 => (Min => R.Max + One, Max => L.Max)];
         end if;
      end "-";
   begin
      --  Get the Set so it is easier to modify
      List.Update_Element (Others_Cur, Get_Set'Access);

      Cur_Others_Segment := New_Set.First;

      while Has_Element (Cur_Alt) loop

         --  Move the cursor in the "others" set until we have an intersection
         --  or we are past the current alternative range

         while Has_Element (Cur_Others_Segment)
              and then not Overlap
                             (Element (Cur_Others_Segment), Element (Cur_Alt))
              and then Element (Cur_Others_Segment) < Element (Cur_Alt)
         loop
            Next (Cur_Others_Segment);
         end loop;

         exit when not Has_Element (Cur_Others_Segment);
         declare
            Sub_Res : constant Subtraction_Result :=
              Element (Cur_Others_Segment) - Element (Cur_Alt);
            --  Compute difference

            Delete_Cur : Cursor := Cur_Others_Segment;
            --  Save current position to delete the current range if needed

            New_Elt_Cur : Cursor;
            Inserted : Boolean;
         begin
            if Sub_Res'Length /= 1
              or else Sub_Res (1) /= Element (Cur_Others_Segment)
            then

               --  Here if there is an intersection between the current others
               --  range and the current alternative range. Prefetch the next
               --  others range and delete the current others range.

               Next (Cur_Others_Segment);
               New_Set.Delete (Delete_Cur);

               if Sub_Res'Length = 1 then

                  --  Single element from the difference, it is either before
                  --  the current alternative range or after.
                  --  If it is after however, it will be before what we
                  --  currently have in Cur_Others_Segment, so it needs to be
                  --  the next range to to be checked against the next
                  --  alternative range.

                  New_Set.Insert (Sub_Res (1), New_Elt_Cur, Inserted);
                  if Element (Cur_Alt) < Element (New_Elt_Cur) then
                     Cur_Others_Segment := New_Elt_Cur;
                  end if;
               elsif Sub_Res'Length = 2 then
                  --  If there are two ranges resulting from the difference,
                  --  then we have both cases described above, and we already
                  --  know that the next element that needs to be processed is
                  --  Sub_Res (2), so update Cur_Others_Segment to point to it.

                  New_Set.Insert (Sub_Res (1));
                  New_Set.Insert (Sub_Res (2), Cur_Others_Segment, Inserted);
               end if;
            end if;
         end;
         Next (Cur_Alt);
      end loop;

      --  Store back the List in the variant_choice record.

      List.Update_Element (Others_Cur, Update_Set'Access);

   end Subtract_Choice_From_Other;

   -----------------------------------
   -- Translate_Component_Decl_List --
   -----------------------------------

   function Translate_Component_Decl_List
     (Decl_List : Ada_Node_List;
      Res       : in out Component_Maps.Map) return Unbounded_String
   is
      Current_Typ : Translation_Result;
      Comp_Decl : Component_Decl;
   begin
      for Decl of Decl_List loop
         if Kind (Decl) in Ada_Null_Component_Decl then
            return Null_Unbounded_String;
         end if;
         Comp_Decl := Decl.As_Component_Decl;
         Current_Typ := Translate
           (Comp_Decl.F_Component_Def.F_Type_Expr, Verbose_Diag);
         if not Current_Typ.Success then
            return "Failed to translate type of component"
                     & Comp_Decl.Image & ": " & Current_Typ.Diagnostics;
         end if;
         for Id of Comp_Decl.F_Ids loop
            Res.Insert (Key => +Id.As_Defining_Name.Text,
                        New_Item => Current_Typ.Res);
         end loop;
      end loop;
      return Null_Unbounded_String;
   end Translate_Component_Decl_List;

   function Translate_Variant_Part
     (Node          : LAL.Variant_Part;
      Discriminants : Component_Maps.Map)
     return Record_Types.Variant_Part
   is
      use Variant_Choice_Lists;
      Res        : Record_Types.Variant_Part;
      Choice_Min : Big_Int.Big_Integer;
      Choice_Max : Big_Int.Big_Integer;
      Has_Others : Boolean := False;
   begin
      Res.Discr_Name := +Node.F_Discr_Name.P_Referenced_Defining_Name.Text;

      for Var_Choice of Node.F_Variant loop
         declare
            Choice_Trans : Variant_Choice;

            Has_Variant : constant Boolean :=
              not Var_Choice.As_Variant.F_Components.F_Variant_Part.Is_Null;

            Diagnostics : constant Unbounded_String :=
              Translate_Component_Decl_List
                (Var_Choice.As_Variant.F_Components.F_Components,
                 Choice_Trans.Components);
         begin
            if Diagnostics /= Null_Unbounded_String then
               raise Translation_Error with
                 "error while translating Variant part: "
                 & To_String (Diagnostics);
            end if;
            for Alt of Var_Choice.F_Choices loop
               case Alt.Kind is
                  when Ada_Expr =>
                     if Alt.Kind in Ada_Bin_Op then
                        if Alt.As_Bin_Op.F_Op.Kind in Ada_Op_Double_Dot then
                           Choice_Min := Big_Int.From_String
                             (New_Eval_As_Int (Alt.As_Bin_Op.F_Left).Image);
                           Choice_Max := Big_Int.From_String
                             (New_Eval_As_Int (Alt.As_Bin_Op.F_Right).Image);
                           Choice_Trans.Alt_Set.Insert
                             ((Min => Choice_Min, Max => Choice_Max));
                        else
                           Choice_Min := Big_Int.From_String
                             (New_Eval_As_Int (Alt.As_Expr).Image);
                           Choice_Trans.Alt_Set.Insert
                             ((Min => Choice_Min, Max => Choice_Min));
                        end if;
                     elsif Alt.Kind in Ada_Name
                       and then not Is_Null
                         (Alt.As_Name.P_Name_Designated_Type)
                     then
                        Choice_Min :=
                          Big_Int.From_String
                            (New_Eval_As_Int (Low_Bound
                               (Alt.As_Name.P_Name_Designated_Type
                                .P_Discrete_Range)).Image);
                        Choice_Max :=
                          Big_Int.From_String
                            (New_Eval_As_Int (High_Bound
                              (Alt.As_Name.P_Name_Designated_Type
                               .P_Discrete_Range)).Image);
                        Choice_Trans.Alt_Set.Insert
                          ((Min => Choice_Min, Max => Choice_Max));
                     else
                        Choice_Min := Big_Int.From_String
                        (New_Eval_As_Int (Alt.As_Expr).Image);
                        Choice_Trans.Alt_Set.Insert
                        ((Min => Choice_Min, Max => Choice_Min));
                     end if;
                  when Ada_Others_Designator_Range =>
                     Choice_Trans.Alt_Set.Clear;
                     Has_Others := True;
                     if not Component_Maps.Has_Element
                          (Discriminants.Find (Res.Discr_Name))
                     then
                        raise Translation_Error with
                          "Unknown discriminant name "
                           & To_String (Res.Discr_Name);
                     end if;

                     --  This is not really accurate for enum types if the
                     --  various enum literal positions are not contiguous.

                     Choice_Trans.Alt_Set.Insert
                       ((Min => As_Discrete_Typ
                           (Discriminants.Element (Res.Discr_Name)).Low_Bound,
                         Max => As_Discrete_Typ
                           (Discriminants.Element (Res.Discr_Name)).High_Bound)
                       );
                  when others =>
                     raise Translation_Error with
                       "Unexpected node kind for a variant choice" & Alt.Image;
               end case;
               exit when Alt.Kind in Ada_Others_Designator_Range;
            end loop;
            if Has_Variant then
               Choice_Trans.Variant := new Record_Types.Variant_Part'
                   (Translate_Variant_Part (Var_Choice.As_Variant
                    .F_Components.F_Variant_Part, Discriminants));
            end if;
            Res.Variant_Choices.Append (Choice_Trans);
         end;
      end loop;

      if Has_Others then
         for Choice_Cur in Res.Variant_Choices.Iterate loop
            exit when Choice_Cur = Res.Variant_Choices.Last;
            Subtract_Choice_From_Other
              (Res.Variant_Choices.Last,
               Element (Choice_Cur),
               Res.Variant_Choices);
         end loop;
      end if;

      return Res;
   end Translate_Variant_Part;

   ---------------------------
   -- Translate_Record_Decl --
   ---------------------------

   function Translate_Record_Decl
     (Decl : Base_Type_Decl) return Translation_Result
   is

      procedure Apply_Constraints
        (Decl, Root : Base_Type_Decl; Res : in out Discriminated_Record_Typ);
      --  Modify Res to include all the discriminant constraints present in
      --  the type derivation / subtype decl chain.

      -----------------------
      -- Apply_Constraints --
      -----------------------

      procedure Apply_Constraints
        (Decl, Root : Base_Type_Decl; Res : in out Discriminated_Record_Typ)
      is
      begin
         --  The original Decl of a record is not constrained.

         if Decl = Root then
            return;
         end if;

         case Kind (Decl) is
            when Ada_Type_Decl =>

               --  First apply constraints of the ancestor type

               Apply_Constraints
                 (Decl.As_Type_Decl.F_Type_Def.As_Derived_Type_Def
                  .F_Subtype_Indication.F_Name.P_Name_Designated_Type,
                  Root,
                  Res);

               --  Then apply the effects of the type derivation

               Res := Apply_Record_Derived_Type_Decl (Decl.As_Type_Decl, Res);

            when Ada_Subtype_Decl_Range =>

               --  First apply the constraints of the ancestor type

               Apply_Constraints
                 (Decl.As_Subtype_Decl.F_Subtype.F_Name.P_Name_Designated_Type,
                  Root,
                  Res);

               --  The register the eventual constraints imposed by the subtype
               --  definition

               Apply_Record_Subtype_Decl (Decl.As_Subtype_Decl.F_Subtype, Res);

            when others =>
               --  This should not be reachable
               null;
         end case;
      end Apply_Constraints;

      Actual_Decl : Type_Decl;
      --  The type decl where the components of the array are actually defined.
      --  For now we don't support tagged types, and thus record extension, so
      --  the whole list of components is available in a single type
      --  declaration. Other subtypes or derived types may only add
      --  discriminant constraints or rebind discriminants.

      Failure_Reason : Unbounded_String;

   --  Start of processing for Translate_Record_Decl;

   begin

      --  First the simple case of an undiscriminated record

      if Kind (Decl.P_Root_Type.P_Full_View) in Ada_Type_Decl
        and then Kind (Decl.P_Root_Type.P_Full_View.As_Type_Decl.F_Type_Def)
                   in Ada_Record_Type_Def_Range
        and then Is_Null
                   (Decl.P_Root_Type.P_Full_View.As_Type_Decl.F_Discriminants)
      then
         Actual_Decl := Decl.P_Root_Type.P_Full_View.As_Type_Decl;

         declare
            Trans_Res : Nondiscriminated_Record_Typ;
            Comp_List : constant Ada_Node_List :=
              Actual_Decl.F_Type_Def.As_Record_Type_Def.F_Record_Def
              .F_Components.F_Components;
         begin

            Failure_Reason := Translate_Component_Decl_List
               (Comp_List, Trans_Res.Component_Types);

            if Failure_Reason = Null_Unbounded_String then
               Trans_Res.Static_Gen :=
                 (for all Comp_Ref of Trans_Res.Component_Types
                    => Comp_Ref.Get.Supports_Static_Gen);

               return Res : Translation_Result (Success => True) do
                  Res.Res.Set (Trans_Res);
               end return;

            else
               return (Success => False,
                 Diagnostics => Failure_Reason);
            end if;
         end;

      else
         --  Now the rest

         Actual_Decl := Decl.P_Root_Type.P_Full_View.As_Type_Decl;

         declare
            Trans_Res : Discriminated_Record_Typ
              (Constrained => Record_Constrained
                                (Decl, Actual_Decl.As_Base_Type_Decl));

            Discriminant_List : constant Discriminant_Spec_List :=
              Actual_Decl.F_Discriminants.As_Known_Discriminant_Part
              .F_Discr_Specs;
            --  ??? We assume that we only have known discriminants for the
            --  moment as we are supposed to be translating the full view of
            --  the type, will need to revisit this to double check.

            Current_Type : Translation_Result;
            Comp_Decl    : constant Component_List :=
              Actual_Decl.F_Type_Def.As_Record_Type_Def.F_Record_Def
              .F_Components;
         begin

            --  First translate the list of discriminants

            for Spec of Discriminant_List loop
               if not Is_Null (Spec.F_Default_Expr) then
                  Trans_Res.Mutable := True;
               end if;
               Current_Type := Translate (Spec.F_Type_Expr, Verbose_Diag);
               if not Current_Type.Success then
                  Failure_Reason := "Failed to translate discriminant spec "
                                    & Spec.Image & ": "
                                    & Current_Type.Diagnostics;
                  goto Failed_Discr_Rec_Translation;
               end if;
               for Def_Name of Spec.F_Ids loop
                  Trans_Res.Discriminant_Types.Insert
                    (Key      => +Def_Name.As_Defining_Name.Text,
                     New_Item => Current_Type.Res);
               end loop;
            end loop;

            --  Then the components always present

            Failure_Reason :=
              Translate_Component_Decl_List
                (Comp_Decl.F_Components, Trans_Res.Component_Types);

            if Failure_Reason /= Null_Unbounded_String then
               return (Success => False,
                    Diagnostics => Failure_Reason);
            end if;

            --  And then the variant part if any

            if not Comp_Decl.F_Variant_Part.Is_Null then
               Trans_Res.Variant :=
                 new Record_Types.Variant_Part'
                   (Translate_Variant_Part
                     (Comp_Decl.F_Variant_Part, Trans_Res.Discriminant_Types));
            end if;

            --  If the record is actually a constrained type, record the
            --  constraints now.

            if Trans_Res.Constrained then
               Apply_Constraints
                 (Decl, Actual_Decl.As_Base_Type_Decl, Trans_Res);
            end if;

            Trans_Res.Static_Gen :=
              (for all Comp_Ref of Trans_Res.Component_Types
                 => Comp_Ref.Get.Supports_Static_Gen)
              and then (for all Disc_Ref of Trans_Res.Discriminant_Types
                          => Disc_Ref.Get.Supports_Static_Gen)
              and then
                (not Trans_Res.Constrained
                 or else (for all Const of Trans_Res.Discriminant_Constraint
                            => Const.Kind in Static | Discriminant))
              and then Variant_Support_Static_Gen (Trans_Res.Variant);

            --  Apply_Constraints can actually return a type that isn't
            --  discriminated or that isn't constrained, so lets try to
            --  convert Trans_Res to the correct kind depending on the
            --  attributes.

            if Trans_Res.Constrained
              and then Trans_Res.Discriminant_Constraint.Is_Empty
            then
               if Trans_Res.Discriminant_Types.Is_Empty then

                  --  Normally only checking for the discriminant is sufficient
                  --  to check if Trans_Res will is actually a non
                  --  discriminated type, but we may have some lingering non
                  --  static constraints that don't allow us to determine
                  --  what the final list of components is.

                  if Trans_Res.Variant /= null then
                     Free_Variant (Trans_Res.Variant);
                  end if;

                  return Res : Translation_Result (Success => True) do
                     Res.Res.Set (Nondiscriminated_Record_Typ'
                       (Component_Types => Trans_Res.Component_Types,
                        Static_Gen      => Trans_Res.Static_Gen,
                        others          => <>));
                  end return;

               else
                  return Res : Translation_Result (Success => True) do
                     declare
                        Rec_Typ : Discriminated_Record_Typ
                          (Constrained => False);
                     begin
                        Rec_Typ.Component_Types.Move
                          (Trans_Res.Component_Types);
                        Rec_Typ.Discriminant_Types.Move
                          (Trans_Res.Discriminant_Types);
                        Rec_Typ.Variant := Trans_Res.Variant;
                        Rec_Typ.Mutable := Trans_Res.Mutable;
                        Rec_Typ.Static_Gen := Trans_Res.Static_Gen;
                        Res.Res.Set (Rec_Typ);
                     end;
                  end return;
               end if;
            end if;

            return Res : Translation_Result (Success => True) do
               Res.Res.Set (Trans_Res);
            end return;

            <<Failed_Discr_Rec_Translation>>
            if Trans_Res.Variant /= null then
               Free_Variant (Trans_Res.Variant);
            end if;
            return (Success => False,
                    Diagnostics => Failure_Reason);
         end;
      end if;
      exception
         when Exc : Translation_Error =>
            return (Success => False,
                    Diagnostics => To_Unbounded_String
                       (Ada.Exceptions.Exception_Message (Exc)));
   end Translate_Record_Decl;

   -------------------------
   -- Eval_Discrete_Range --
   -------------------------

   function Eval_Discrete_Range
     (Rng : Discrete_Range)
      return TGen.Types.Constraints.Discrete_Range_Constraint
   is
      Low_Bnd  : Discrete_Constraint_Value;
      High_Bnd : Discrete_Constraint_Value;
   begin
      begin
         if Low_Bound (Rng).P_Is_Static_Expr then
            Low_Bnd :=
            (Kind    => Static,
               Int_Val =>
               Big_Int.From_String (New_Eval_As_Int (Low_Bound (Rng)).Image));
         elsif Low_Bound (Rng).Kind in Ada_Name
            and then not Is_Null
                           (Low_Bound (Rng).As_Name.P_Referenced_Defining_Name)
            and then Kind (Low_Bound (Rng).As_Name.P_Referenced_Defining_Name
                           .Parent.Parent) in Ada_Discriminant_Spec_Range
         then
            Low_Bnd :=
            (Kind      => Discriminant,
             Disc_Name => +Low_Bound (Rng).As_Name.P_Referenced_Defining_Name
                          .Text);
         else
            Low_Bnd :=
              (Kind => Non_Static,
               Text => +Low_Bound (Rng).Text);
         end if;
      exception
         when Non_Static_Error =>
            Low_Bnd := (Kind => Non_Static, Text => +Low_Bound (Rng).Text);
      end;

      begin
         if High_Bound (Rng).P_Is_Static_Expr then
            High_Bnd :=
            (Kind    => Static,
               Int_Val =>
               Big_Int.From_String (New_Eval_As_Int (High_Bound (Rng)).Image));
         elsif High_Bound (Rng).Kind in Ada_Name
            and then not Is_Null
                           (High_Bound (Rng).As_Name
                            .P_Referenced_Defining_Name)
            and then Kind (High_Bound (Rng).As_Name.P_Referenced_Defining_Name
                           .Parent.Parent) in Ada_Discriminant_Spec_Range
         then
            High_Bnd :=
            (Kind      => Discriminant,
             Disc_Name => +High_Bound (Rng).As_Name.P_Referenced_Defining_Name
                          .Text);
         else
            High_Bnd :=
              (Kind => Non_Static,
               Text => +High_Bound (Rng).Text);
         end if;
      exception
         when Non_Static_Error =>
            High_Bnd := (Kind => Non_Static, Text => +High_Bound (Rng).Text);
      end;

      return (Low_Bnd, High_Bnd);
   end Eval_Discrete_Range;

   -----------------------------------------
   -- Translate_Discrete_Range_Constraint --
   -----------------------------------------

   function Translate_Discrete_Range_Constraint
     (Node : LAL.Range_Constraint) return Discrete_Range_Constraint
   is
      Min, Max : Expr;
   begin
      case Kind (Node.F_Range.F_Range) is
         when Ada_Attribute_Ref_Range =>
            pragma Assert (Node.F_Range.F_Range.As_Attribute_Ref.F_Prefix
                           .P_Name_Designated_Type.P_Is_Discrete_Type);
            Min :=
              Low_Bound (Node.F_Range.F_Range.As_Attribute_Ref.F_Prefix
                         .P_Name_Designated_Type.P_Discrete_Range).As_Expr;
            Max :=
              High_Bound (Node.F_Range.F_Range.As_Attribute_Ref.F_Prefix
                          .P_Name_Designated_Type.P_Discrete_Range).As_Expr;
         when Ada_Bin_Op_Range =>
            pragma Assert (Node.F_Range.F_Range.As_Bin_Op.F_Op
                           in Ada_Op_Double_Dot_Range);
            Min := Node.F_Range.F_Range.As_Bin_Op.F_Left;
            Max := Node.F_Range.F_Range.As_Bin_Op.F_Right;
         when others =>
            raise Translation_Error with
              "Unexpected expression for a range constraint: "
              & Kind_Name (Node.F_Range.F_Range);
      end case;

      return Eval_Discrete_Range (Create_Discrete_Range (Min, Max));

   end Translate_Discrete_Range_Constraint;

   function Translate_Real_Constraints
     (Node : LAL.Constraint) return TGen.Types.Constraints.Constraint'Class
   is
      Range_Spc : constant LAL.Range_Spec := Extract_Real_Range_Spec (Node);
      Rnge : Real_Range_Constraint;
   begin

      if not Is_Null (Range_Spc) then
         Rnge := Translate_Real_Range_Spec (Range_Spc);
      end if;

      case Kind (Node) is
         when Ada_Range_Constraint_Range =>
            pragma Assert (not Is_Null (Range_Spc));
            return Rnge;
         when Ada_Digits_Constraint_Range =>
            if Node.As_Digits_Constraint.F_Digits.P_Is_Static_Expr then
               begin
                  declare
                     Digits_Val : constant Big_Int.Big_Integer :=
                     Big_Int.From_String
                        (New_Eval_As_Int
                           (Node.As_Digits_Constraint.F_Digits).Image);
                  begin
                     if not Is_Null (Range_Spc) then
                        return TGen.Types.Constraints.Digits_Constraint'
                        (Has_Range    => True,
                         Digits_Value => (Kind    => Static,
                                          Int_Val => Digits_Val),
                         Range_Value => Rnge);
                     else
                        return TGen.Types.Constraints.Digits_Constraint'
                        (Has_Range   => False,
                         Digits_Value => (Kind    => Static,
                                          Int_Val => Digits_Val));
                     end if;
                  end;
               exception
                  when Non_Static_Error =>
                     if not Is_Null (Range_Spc) then
                        return TGen.Types.Constraints.Digits_Constraint'
                        (Has_Range    => True,
                         Digits_Value => (Kind => Non_Static,
                                          Text => +Node.As_Digits_Constraint
                                                   .F_Digits.Text),
                         Range_Value => Rnge);
                     else
                        return TGen.Types.Constraints.Digits_Constraint'
                        (Has_Range   => False,
                         Digits_Value => (Kind    => Non_Static,
                                          Text    => +Node.As_Digits_Constraint
                                                      .F_Digits.Text));
                     end if;
               end;
            end if;

            --  Case of a non static digit value. This is not possible
            --  according to RM 3.5.9 (5/4).

            raise Translation_Error with
              "Non static digits constraints are forbidden:" & Node.Image;

         when Ada_Delta_Constraint_Range =>
            raise Translation_Error with
              "Delta constraints for anonymous types not implemented yet";
         when others =>
            raise Translation_Error with
              "Unexpected expression for a real type constraint: "
              & Kind_Name (Node);
      end case;
   end Translate_Real_Constraints;

   function Translate_Index_Constraints
     (Node     : LAL.Constraint;
      Num_Dims : Positive)
     return TGen.Types.Constraints.Index_Constraints
   is
      Constraint_List : constant Local_Ada_Node_Arr :=
        Gather_Index_Constraint_Nodes (Node, Num_Dims);
      Current_Index : Positive := 1;

      Discr_Range     : Discrete_Range;
      Referenced_Type : Base_Type_Decl;
   begin
      return Res : Index_Constraints (Num_Dims) do
         for Cst of Constraint_List loop
            case Kind (Cst) is
               when Ada_Subtype_Indication_Range =>
                  if not Is_Null (Cst.As_Subtype_Indication.F_Constraint) then
                     Res.Constraint_Array (Current_Index) :=
                       TGen.Types.Constraints.Index_Constraint'
                         (Present        => True,
                          Discrete_Range => Translate_Discrete_Range_Constraint
                            (Cst.As_Subtype_Indication.F_Constraint
                             .As_Range_Constraint));
                     goto Skip_Range_Translation;
                  else
                     Referenced_Type := Cst.As_Subtype_Indication.F_Name
                                        .P_Name_Designated_Type;
                     Discr_Range := Cst.As_Subtype_Indication.F_Name
                                    .P_Name_Designated_Type.P_Discrete_Range;
                  end if;
               when Ada_Bin_Op_Range =>
                  pragma Assert
                    (Kind (Cst.As_Bin_Op.F_Op) in Ada_Op_Double_Dot_Range);
                  Discr_Range := Create_Discrete_Range
                    (Cst.As_Bin_Op.F_Left, Cst.As_Bin_Op.F_Right);
               when Ada_Attribute_Ref_Range =>
                  Discr_Range := Cst.As_Attribute_Ref.F_Prefix
                                 .P_Name_Designated_Type.P_Discrete_Range;
                  Referenced_Type := Cst.As_Attribute_Ref.F_Prefix
                                     .P_Name_Designated_Type;
               when others =>
                  Discr_Range :=
                    Cst.As_Name.P_Name_Designated_Type.P_Discrete_Range;
                  Referenced_Type :=  Cst.As_Name.P_Name_Designated_Type;
            end case;

            if not (Is_Null (Referenced_Type)
                    or else Referenced_Type.P_Is_Static_Decl)
            then
               Res.Constraint_Array (Current_Index) :=
                  TGen.Types.Constraints.Index_Constraint'
                    (Present        => True,
                     Discrete_Range =>
                        (Low_Bound  => (Kind => Non_Static, others => <>),
                         High_Bound => (Kind => Non_Static,
                                        Text => +Cst.Text)));
               goto Skip_Range_Translation;
            end if;

            Res.Constraint_Array (Current_Index) :=
            TGen.Types.Constraints.Index_Constraint'
              (Present        => True,
               Discrete_Range => Eval_Discrete_Range (Discr_Range));

            <<Skip_Range_Translation>>
            Current_Index := Current_Index + 1;
         end loop;
      end return;
   end Translate_Index_Constraints;

   function Translate_Discriminant_Constraints
     (Node : LAL.Composite_Constraint)
     return TGen.Types.Constraints.Discriminant_Constraints
   is
      New_Item : Discrete_Constraint_Value;
   begin
      return Res : TGen.Types.Constraints.Discriminant_Constraints do
         for Pair of Node.F_Constraints.P_Zip_With_Params loop
            New_Item := (Kind => Non_Static, others => <>);
            begin
               if Actual (Pair).P_Is_Static_Expr then
                  New_Item :=
                    (Kind    => Static,
                     Int_Val => Big_Int.From_String
                                  (New_Eval_As_Int (Actual (Pair)).Image));
               elsif Kind (Actual (Pair)) in Ada_Name
                  and then not Is_Null (
                              Actual (Pair).As_Name.P_Referenced_Defining_Name)
                  and then Kind (Actual (Pair).As_Name
                                 .P_Referenced_Defining_Name.Parent.Parent)
                           in Ada_Discriminant_Spec_Range
               then
                  New_Item :=
                    (Kind      => Discriminant,
                     Disc_Name => +Actual (Pair).As_Name
                                  .P_Referenced_Defining_Name.Text);
               else
                  New_Item := (Kind => Non_Static,
                               Text => +Actual (Pair).Text);
               end if;
               exception
                  when Non_Static_Error =>
                     New_Item := (Kind => Non_Static,
                                  Text => +Actual (Pair).Text);
            end;
            Res.Constraint_Map.Insert
              (Key      => +Param (Pair).Text,
               New_Item => New_Item);
         end loop;
      end return;
   end Translate_Discriminant_Constraints;

   ---------------
   -- Translate --
   ---------------

   function Translate
     (N : LAL.Type_Expr; Verbose : Boolean := False) return Translation_Result
   is
      Type_Decl_Node : Base_Type_Decl;
      Intermediate_Result : Translation_Result;
   begin
      if Kind (N) in Ada_Anonymous_Type_Range then
         Type_Decl_Node := N.As_Anonymous_Type.F_Type_Decl.As_Base_Type_Decl;
      else

         --  For now, work on the full view of the type that we are trying to
         --  translate. If this proves useless/problematic this can be
         --  revisited.

         Type_Decl_Node :=
           N.As_Subtype_Indication.P_Designated_Type_Decl;
      end if;

      Intermediate_Result := Translate (Type_Decl_Node, Verbose);

      if not Intermediate_Result.Success
        or else Kind (N) in Ada_Anonymous_Type
        or else Intermediate_Result.Res.Get.Kind in Unsupported
        or else Is_Null (N.As_Subtype_Indication.F_Constraint)
      then
         return Intermediate_Result;
      end if;
      case Intermediate_Result.Res.Get.Kind is
         when Discrete_Typ_Range =>
            pragma Assert (Kind (N.As_Subtype_Indication.F_Constraint)
                           in Ada_Range_Constraint_Range);
            return Res : Translation_Result (Success => True) do
               Res.Res.Set (Anonymous_Typ'
                 (Name                => Ada_Identifier_Vectors.Empty_Vector,
                  Last_Comp_Unit_Idx  => 1,
                  Fully_Private       =>
                    Intermediate_Result.Res.Get.Fully_Private,
                  Named_Ancestor      => Intermediate_Result.Res,
                  Subtype_Constraints => new Discrete_Range_Constraint'
                    (Translate_Discrete_Range_Constraint
                      (N.As_Subtype_Indication.F_Constraint
                       .As_Range_Constraint))));
            end return;
         when Real_Typ_Range =>
            return Res : Translation_Result (Success => True) do
               Res.Res.Set (Anonymous_Typ'
                 (Name                => Ada_Identifier_Vectors.Empty_Vector,
                  Last_Comp_Unit_Idx  => 1,
                  Named_Ancestor      => Intermediate_Result.Res,
                  Fully_Private       =>
                    Intermediate_Result.Res.Get.Fully_Private,
                  Subtype_Constraints =>
                    new TGen.Types.Constraints.Constraint'Class'
                    (Translate_Real_Constraints
                      (N.As_Subtype_Indication.F_Constraint))));
            end return;
         when Array_Typ_Range =>
            return Res : Translation_Result (Success => True) do
               Res.Res.Set (Anonymous_Typ'
                 (Name                => Ada_Identifier_Vectors.Empty_Vector,
                  Last_Comp_Unit_Idx  => 1,
                  Named_Ancestor      => Intermediate_Result.Res,
                  Fully_Private       =>
                    Intermediate_Result.Res.Get.Fully_Private,
                  Subtype_Constraints => new Index_Constraints'
                    (Translate_Index_Constraints
                      (N.As_Subtype_Indication.F_Constraint,
                       As_Unconstrained_Array_Typ
                         (Intermediate_Result.Res).Num_Dims))));
            end return;
         when Record_Typ_Range =>
            return Res : Translation_Result (Success => True) do
               pragma Assert (Kind (N.As_Subtype_Indication.F_Constraint)
                                 in Ada_Composite_Constraint_Range and
                                N.As_Subtype_Indication.F_Constraint
                                     .As_Composite_Constraint
                                     .P_Is_Discriminant_Constraint);
               Res.Res.Set (Anonymous_Typ'
                 (Name                => Ada_Identifier_Vectors.Empty_Vector,
                  Last_Comp_Unit_Idx  => 1,
                  Named_Ancestor      => Intermediate_Result.Res,
                  Fully_Private       =>
                    Intermediate_Result.Res.Get.Fully_Private,
                  Subtype_Constraints => new Discriminant_Constraints'
                    (Translate_Discriminant_Constraints
                      (N.As_Subtype_Indication.F_Constraint
                       .As_Composite_Constraint))));
            end return;
         when others =>
            return Intermediate_Result;
      end case;
   exception
      when Exc : Property_Error =>
         return (Success     => False,
                 Diagnostics => To_Unbounded_String ("Error translating ")
                                & N.Image & " : "
                                & Ada.Exceptions.Exception_Message (Exc));
      when Exc : Translation_Error =>
         return (Success     => False,
                 Diagnostics =>
                    To_Unbounded_String
                       ("Error translating the following constraints:")
                    & Ada.Exceptions.Exception_Information (Exc));
   end Translate;

   ---------------
   -- Translate --
   ---------------

   function Translate
     (N       : LAL.Base_Type_Decl;
      Verbose : Boolean := False) return Translation_Result
   is
      use Translation_Maps;

      Full_Decl : constant Base_Type_Decl := N.P_Full_View;
      FQN       : constant Ada_Qualified_Name :=
        Convert_Qualified_Name (Full_Decl.P_Fully_Qualified_Name_Array);
   begin
      --  Do not memoize anonymous types

      if Is_Null (Full_Decl.F_Name) then
         return Translate_Internal (Full_Decl, Verbose);
      end if;

      declare
         Cache_T : SP.Ref;
      begin
         --  If we have the type name in the cache, return it

         if Get_From_Cache (FQN, Cache_T) then
            return Res : Translation_Result (Success => True) do
               Res.Res := Cache_T;
            end return;
         end if;

         --  Otherwise, compute the type translation and store it in the cache

         declare
            Trans_Res : constant Translation_Result :=
              Translate_Internal (Full_Decl, Verbose);
         begin
            if Trans_Res.Success then
               Translation_Cache.Insert (FQN, Trans_Res.Res);
               Type_Decl_Cache.Insert (FQN, Full_Decl);
            end if;
            return Trans_Res;
         end;

      end;
   end Translate;

   ------------------------
   -- Translate_Internal --
   ------------------------

   function Translate_Internal
     (N                 : LAL.Base_Type_Decl;
      Verbose           : Boolean := False;
      Assume_Non_Static : Boolean := False) return Translation_Result
   is
      Root_Type : constant Base_Type_Decl := N.P_Root_Type.P_Full_View;
      Is_Static : Boolean := not Assume_Non_Static;
      --  Relevant only for Scalar types / array bounds
      --  / discriminant constraints.

      Type_Name : constant Defining_Name :=
        (if not (Kind (N) in Ada_Anonymous_Type_Decl_Range)
         then N.P_Defining_Name
         else No_Defining_Name);

      Comp_Unit_Idx : constant Positive :=
        Unbounded_Text_Type_Array'(N.P_Enclosing_Compilation_Unit.P_Decl
                                   .P_Fully_Qualified_Name_Array)'Last;

      FQN : constant Ada_Qualified_Name :=
        Convert_Qualified_Name (Type_Name.P_Fully_Qualified_Name_Array);

      First_Part : constant Basic_Decl'Class := N.P_All_Parts (1);
      --  First part of the declaration. Used to determine whether the type we
      --  are translating is private or not.

      Specialized_Res : Translation_Result (Success => True);

   begin
      Verbose_Diag := Verbose;
      Is_Static := Is_Static
        and then N.P_Is_Static_Decl

      --  The T'Base of a discrete type T has unknown bounds

        and then not (Kind (N) in Ada_Discrete_Base_Subtype_Decl);

      if Is_Null (Type_Name) then

         --  Anonymous types at this level are either anonymous array
         --  declarations or anonymous access types, both of which we don't
         --  intend to support.

         Specialized_Res.Res.Set
           (Unsupported_Typ'
             (Reason => To_Unbounded_String
                ("Anonymous array or access type unsupported"),
            others   => <>));
      elsif Text.Image (Type_Name.P_Fully_Qualified_Name) = "System.Address"
      then

         --  Special case for System.Address, which is actually defined as a
         --  modular integer but for which we do not want to generate any
         --  values.

         Specialized_Res.Res.Set (Unsupported_Typ'
           (Reason => To_Unbounded_String ("System.Address unsupported"),
            others => <>));
      elsif First_Part.As_Base_Type_Decl.P_Is_Private
           and then Positive (FQN.Length) - Comp_Unit_Idx > 1
      then
         --  We are dealing with a private type declared in a nested package,
         --  consider this as unsupported.

         Specialized_Res.Res.Set (Unsupported_Typ'
           (Reason =>
              To_Unbounded_String
                ("Private types declared in nested package are not"
                 & " supported"),
            others => <>));
      elsif Root_Type.P_Is_Formal then
         Specialized_Res.Res.Set (Formal_Typ'
           (Reason =>
              To_Unbounded_String ("Generic formal types are unsupported"),
            others => <>));
      elsif Root_Type.P_Is_Int_Type then
         Specialized_Res := Translate_Int_Decl (N);

      elsif P_Is_Derived_Type
          (Node       => N,
           Other_Type => N.P_Bool_Type.As_Base_Type_Decl)
      then
         Specialized_Res.Res.Set (Bool_Typ'(Is_Static => True, others => <>));
      elsif Root_Type.P_Is_Enum_Type then

         if not Is_Static then
            Specialized_Res.Res.Set (Other_Enum_Typ'
              (Is_Static => False, others => <>));
         end if;
         declare
            Root_Type_Name : constant String :=
              Text.Image (Root_Type.P_Unique_Identifying_Name);
         begin
            if Root_Type_Name = "standard.character"
              or else Root_Type_Name = "standard.wide_character"
              or else Root_Type_Name = "standard.wide_wide_character"
            then
               Specialized_Res := Translate_Char_Decl (N);
            else
               Specialized_Res := Translate_Enum_Decl (N, Root_Type);
            end if;
         end;

      elsif Root_Type.P_Is_Float_Type then
         if Is_Static then
            Specialized_Res := Translate_Float_Decl (N);
         else
            Specialized_Res.Res.Set
              (Float_Typ'
               (Is_Static => False,
                Has_Range => False,
                others    => <>));
         end if;

      elsif Root_Type.P_Is_Fixed_Point then
         if Kind (Root_Type.As_Type_Decl.F_Type_Def) in
             Ada_Ordinary_Fixed_Point_Def_Range
         then
            if Is_Static then
               Specialized_Res := Translate_Ordinary_Fixed_Decl (N);
            else
               Specialized_Res.Res.Set
                 (Ordinary_Fixed_Typ'
                    (Is_Static => False,
                     others    => <>));
            end if;
         else
            if Is_Static then
               Specialized_Res := Translate_Decimal_Fixed_Decl (N);
            else
               Specialized_Res.Res.Set
                 (Decimal_Fixed_Typ'
                    (Is_Static => False,
                     Has_Range => False,
                     others    => <>));
            end if;
         end if;

      elsif Root_Type.P_Is_Array_Type then
         Specialized_Res := Translate_Array_Decl (N);

      elsif Root_Type.P_Is_Record_Type then
         if Root_Type.P_Is_Tagged_Type then
            Specialized_Res.Res.Set
              (Unsupported_Typ'
                (Reason => To_Unbounded_String ("tagged types not supported"),
                 others => <>));
         else
            Specialized_Res := Translate_Record_Decl (N);
         end if;

      elsif Root_Type.P_Is_Access_Type then
         Specialized_Res.Res.Set
           (Access_Typ'
              (Reason =>
                 To_Unbounded_String ("Access types are not supported"),
               others => <>));
      else
         Specialized_Res.Res.Set
           (Unsupported_Typ'
              (Reason => To_Unbounded_String ("Unknown type kind"),
               others => <>));
      end if;

      --  Fill the common bits if we got a successful translation

      if Specialized_Res.Success then
         Specialized_Res.Res.Get.Name := FQN;
         Specialized_Res.Res.Get.Last_Comp_Unit_Idx := Comp_Unit_Idx;
         Specialized_Res.Res.Get.Fully_Private := Decl_Is_Fully_Private (N);
      end if;

      return Specialized_Res;

   exception
      when Exc : Property_Error =>
         return
           (Success     => False,
            Diagnostics =>
              To_Unbounded_String ("Error translating ") & N.Image & " : " &
              Ada.Exceptions.Exception_Information (Exc));
      when Exc : Non_Static_Error =>
         if Verbose_Diag then
            Put_Line ("Lal limitation during static evaluation: "
                      & Ada.Exceptions.Exception_Message (Exc));
         end if;
         return Translate_Internal (N, Verbose_Diag, True);
   end Translate_Internal;

   ---------------
   -- Translate --
   ---------------

   function Translate
     (N       : LAL.Base_Subp_Spec;
      Verbose : Boolean := False) return Translation_Result
   is
      F_Typ         : Function_Typ;
      F_Typ_Ref     : SP.Ref;
      Result        : Translation_Result (Success => True);
      Comp_Unit_Idx : constant Positive :=
        Unbounded_Text_Type_Array'(N.P_Enclosing_Compilation_Unit.P_Decl
                                   .P_Fully_Qualified_Name_Array)'Last;

      Parent_Decl : constant Basic_Decl := N.P_Parent_Basic_Decl;
      UID         : constant String :=
        Test.Common.Mangle_Hash_16 (Subp => Parent_Decl);
   begin

      F_Typ.Last_Comp_Unit_Idx := Comp_Unit_Idx;
      F_Typ.Name :=
        Convert_Qualified_Name (Parent_Decl.P_Fully_Qualified_Name_Array)
        & TGen.Strings.Ada_Identifier
           (Ada.Strings.Unbounded.To_Unbounded_String (UID));

      --  Check if we have already translated the function type

      declare
         Cache_T : SP.Ref;
      begin
         if Get_From_Cache (F_Typ.Name, Cache_T) then
            Result.Res := Cache_T;
            return Result;
         end if;
      end;

      for Param of N.P_Params loop
         declare
            Current_Typ : constant Translation_Result :=
              Translate (Param.F_Type_Expr, Verbose);
         begin
            if Current_Typ.Success then

               for Id of Param.F_Ids loop
                  F_Typ.Component_Types.Insert
                    (Key      => +Id.As_Defining_Name.Text,
                     New_Item => Current_Typ.Res);
                  F_Typ.Param_Modes.Insert
                    (Key      => +Id.As_Defining_Name.Text,
                     New_Item =>
                       (case Param.F_Mode is
                        when Ada_Mode_Default | Ada_Mode_In => In_Mode,
                        when Ada_Mode_In_Out                => In_Out_Mode,
                        when others                         => Out_Mode));
               end loop;
            else
               return Current_Typ;
            end if;
         end;
      end loop;

      if not N.P_Returns.Is_Null then
         declare
            Ret : constant Translation_Result :=
              Translate (N.P_Returns, Verbose);
         begin
            if not Ret.Success then
               return (False, Ret.Diagnostics);
            end if;
            F_Typ.Ret_Typ := Ret.Res;
         end;
      else
         F_Typ.Ret_Typ := SP.Null_Ref;
      end if;
      --  Function type was successfully translated

      F_Typ.Subp_UID := +UID;

      --  This function can only be used outside of the private part if none of
      --  its parameter types are fully private.

      F_Typ.Fully_Private :=
        (for some Param of F_Typ.Component_Types => Param.Get.Fully_Private);

      F_Typ_Ref.Set (F_Typ);
      Translation_Cache.Insert (F_Typ.Name, F_Typ_Ref);
      Result.Res := F_Typ_Ref;
      return Result;
   end Translate;

   procedure Print_Cache_Stats is
   begin
      New_Line;
      Put_Line ("Items in cache :" & Translation_Cache.Length'Image);
      Put_Line ("Cache hits  :" & Cache_Hits'Image);
      Put_Line ("Cache misses:" & Cache_Miss'Image);
   end Print_Cache_Stats;

   procedure Clear_Cache is
   begin
      Translation_Cache.Clear;
   end Clear_Cache;

end TGen.Types.Translation;