------------------------------------------------------------------------------
-- --
-- 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 --
-- . --
------------------------------------------------------------------------------
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;
<>
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;
<>
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;
<>
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));
<>
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;