From ec5cdde54b8b59e6bb0ecdd05938adc8f40e8521 Mon Sep 17 00:00:00 2001 From: Tristan Gingold Date: Sun, 5 May 2019 08:13:25 +0200 Subject: vhdl: move evaluation to vhdl child. --- src/vhdl/evaluation.adb | 3994 ------------------------------- src/vhdl/evaluation.ads | 218 -- src/vhdl/simulate/simul-elaboration.adb | 4 +- src/vhdl/simulate/simul-execution.adb | 12 +- src/vhdl/translate/trans-chap14.adb | 2 +- src/vhdl/translate/trans-chap3.adb | 2 +- src/vhdl/translate/trans-chap6.adb | 2 +- src/vhdl/translate/trans-chap7.adb | 2 +- src/vhdl/translate/trans-chap8.adb | 2 +- src/vhdl/vhdl-evaluation.adb | 3994 +++++++++++++++++++++++++++++++ src/vhdl/vhdl-evaluation.ads | 218 ++ src/vhdl/vhdl-ieee-vital_timing.adb | 6 +- src/vhdl/vhdl-sem_assocs.adb | 2 +- src/vhdl/vhdl-sem_decls.adb | 2 +- src/vhdl/vhdl-sem_expr.adb | 2 +- src/vhdl/vhdl-sem_names.adb | 2 +- src/vhdl/vhdl-sem_psl.adb | 2 +- src/vhdl/vhdl-sem_specs.adb | 2 +- src/vhdl/vhdl-sem_stmts.adb | 2 +- src/vhdl/vhdl-sem_types.adb | 2 +- 20 files changed, 4236 insertions(+), 4236 deletions(-) delete mode 100644 src/vhdl/evaluation.adb delete mode 100644 src/vhdl/evaluation.ads create mode 100644 src/vhdl/vhdl-evaluation.adb create mode 100644 src/vhdl/vhdl-evaluation.ads (limited to 'src/vhdl') diff --git a/src/vhdl/evaluation.adb b/src/vhdl/evaluation.adb deleted file mode 100644 index a3355f7a6..000000000 --- a/src/vhdl/evaluation.adb +++ /dev/null @@ -1,3994 +0,0 @@ --- Evaluation of static expressions. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL 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. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Ada.Unchecked_Deallocation; -with Interfaces; -with Vhdl.Scanner; -with Errorout; use Errorout; -with Name_Table; use Name_Table; -with Str_Table; -with Iirs_Utils; use Iirs_Utils; -with Vhdl.Std_Package; use Vhdl.Std_Package; -with Flags; use Flags; -with Std_Names; -with Ada.Characters.Handling; -with Grt.Fcvt; - -package body Evaluation is - -- If FORCE is true, always return a literal. - function Eval_Expr_Keep_Orig (Expr : Iir; Force : Boolean) return Iir; - - function Eval_Enum_To_String (Lit : Iir; Orig : Iir) return Iir; - function Eval_Integer_Image (Val : Iir_Int64; Orig : Iir) return Iir; - - function Eval_Scalar_Compare (Left, Right : Iir) return Compare_Type; - - function Get_Physical_Value (Expr : Iir) return Iir_Int64 - is - pragma Unsuppress (Overflow_Check); - Kind : constant Iir_Kind := Get_Kind (Expr); - Unit : Iir; - begin - case Kind is - when Iir_Kind_Physical_Int_Literal - | Iir_Kind_Physical_Fp_Literal => - -- Extract Unit. - Unit := Get_Physical_Literal (Get_Physical_Unit (Expr)); - pragma Assert (Get_Physical_Unit (Unit) - = Get_Primary_Unit (Get_Type (Unit))); - case Kind is - when Iir_Kind_Physical_Int_Literal => - return Get_Value (Expr) * Get_Value (Unit); - when Iir_Kind_Physical_Fp_Literal => - return Iir_Int64 - (Get_Fp_Value (Expr) * Iir_Fp64 (Get_Value (Unit))); - when others => - raise Program_Error; - end case; - when Iir_Kind_Unit_Declaration => - return Get_Value (Get_Physical_Literal (Expr)); - when others => - Error_Kind ("get_physical_value", Expr); - end case; - end Get_Physical_Value; - - function Build_Integer (Val : Iir_Int64; Origin : Iir) - return Iir_Integer_Literal - is - Res : Iir_Integer_Literal; - begin - Res := Create_Iir (Iir_Kind_Integer_Literal); - Location_Copy (Res, Origin); - Set_Value (Res, Val); - Set_Type (Res, Get_Type (Origin)); - Set_Literal_Origin (Res, Origin); - Set_Expr_Staticness (Res, Locally); - return Res; - end Build_Integer; - - function Build_Floating (Val : Iir_Fp64; Origin : Iir) - return Iir_Floating_Point_Literal - is - Res : Iir_Floating_Point_Literal; - begin - Res := Create_Iir (Iir_Kind_Floating_Point_Literal); - Location_Copy (Res, Origin); - Set_Fp_Value (Res, Val); - Set_Type (Res, Get_Type (Origin)); - Set_Literal_Origin (Res, Origin); - Set_Expr_Staticness (Res, Locally); - return Res; - end Build_Floating; - - function Build_Enumeration_Constant (Val : Iir_Index32; Origin : Iir) - return Iir_Enumeration_Literal - is - Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); - Enum_List : constant Iir_Flist := - Get_Enumeration_Literal_List (Enum_Type); - Lit : constant Iir_Enumeration_Literal := - Get_Nth_Element (Enum_List, Integer (Val)); - Res : Iir_Enumeration_Literal; - begin - Res := Copy_Enumeration_Literal (Lit); - Location_Copy (Res, Origin); - Set_Literal_Origin (Res, Origin); - return Res; - end Build_Enumeration_Constant; - - function Build_Physical (Val : Iir_Int64; Origin : Iir) - return Iir_Physical_Int_Literal - is - Res : Iir_Physical_Int_Literal; - Unit_Name : Iir; - begin - Res := Create_Iir (Iir_Kind_Physical_Int_Literal); - Location_Copy (Res, Origin); - Unit_Name := Get_Primary_Unit (Get_Base_Type (Get_Type (Origin))); - Set_Physical_Unit (Res, Unit_Name); - Set_Value (Res, Val); - Set_Type (Res, Get_Type (Origin)); - Set_Literal_Origin (Res, Origin); - Set_Expr_Staticness (Res, Locally); - return Res; - end Build_Physical; - - function Build_Discrete (Val : Iir_Int64; Origin : Iir) return Iir is - begin - case Get_Kind (Get_Type (Origin)) is - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - return Build_Enumeration_Constant (Iir_Index32 (Val), Origin); - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Integer_Subtype_Definition => - return Build_Integer (Val, Origin); - when others => - Error_Kind ("build_discrete", Get_Type (Origin)); - end case; - end Build_Discrete; - - function Build_String (Val : String8_Id; Len : Nat32; Origin : Iir) - return Iir - is - Res : Iir; - begin - Res := Create_Iir (Iir_Kind_String_Literal8); - Location_Copy (Res, Origin); - Set_String8_Id (Res, Val); - Set_String_Length (Res, Len); - Set_Type (Res, Get_Type (Origin)); - Set_Literal_Origin (Res, Origin); - Set_Expr_Staticness (Res, Locally); - return Res; - end Build_String; - - -- Build a simple aggregate composed of EL_LIST from ORIGIN. STYPE is the - -- type of the aggregate. DEF_TYPE should be either Null_Iir or STYPE. It - -- is set only when a new subtype has been created for the aggregate. - function Build_Simple_Aggregate (El_List : Iir_Flist; - Origin : Iir; - Stype : Iir; - Def_Type : Iir := Null_Iir) - return Iir_Simple_Aggregate - is - Res : Iir_Simple_Aggregate; - begin - Res := Create_Iir (Iir_Kind_Simple_Aggregate); - Location_Copy (Res, Origin); - Set_Simple_Aggregate_List (Res, El_List); - Set_Type (Res, Stype); - Set_Literal_Origin (Res, Origin); - Set_Expr_Staticness (Res, Locally); - Set_Literal_Subtype (Res, Def_Type); - return Res; - end Build_Simple_Aggregate; - - function Build_Overflow (Origin : Iir; Expr_Type : Iir) return Iir - is - Res : Iir; - begin - Res := Create_Iir (Iir_Kind_Overflow_Literal); - Location_Copy (Res, Origin); - Set_Type (Res, Expr_Type); - Set_Literal_Origin (Res, Origin); - Set_Expr_Staticness (Res, Locally); - return Res; - end Build_Overflow; - - function Build_Overflow (Origin : Iir) return Iir is - begin - return Build_Overflow (Origin, Get_Type (Origin)); - end Build_Overflow; - - function Build_Constant (Val : Iir; Origin : Iir) return Iir - is - Res : Iir; - begin - -- Note: this must work for any literals, because it may be used to - -- replace a locally static constant by its initial value. - case Get_Kind (Val) is - when Iir_Kind_Integer_Literal => - Res := Create_Iir (Iir_Kind_Integer_Literal); - Set_Value (Res, Get_Value (Val)); - - when Iir_Kind_Floating_Point_Literal => - Res := Create_Iir (Iir_Kind_Floating_Point_Literal); - Set_Fp_Value (Res, Get_Fp_Value (Val)); - - when Iir_Kind_Enumeration_Literal => - return Build_Enumeration_Constant - (Iir_Index32 (Get_Enum_Pos (Val)), Origin); - - when Iir_Kind_Physical_Int_Literal - | Iir_Kind_Physical_Fp_Literal => - Res := Create_Iir (Iir_Kind_Physical_Int_Literal); - Set_Physical_Unit (Res, Get_Primary_Unit - (Get_Base_Type (Get_Type (Origin)))); - Set_Value (Res, Get_Physical_Value (Val)); - - when Iir_Kind_Unit_Declaration => - Res := Create_Iir (Iir_Kind_Physical_Int_Literal); - Set_Value (Res, Get_Physical_Value (Val)); - Set_Physical_Unit (Res, Get_Primary_Unit (Get_Type (Val))); - - when Iir_Kind_String_Literal8 => - Res := Create_Iir (Iir_Kind_String_Literal8); - Set_String8_Id (Res, Get_String8_Id (Val)); - Set_String_Length (Res, Get_String_Length (Val)); - - when Iir_Kind_Simple_Aggregate => - Res := Create_Iir (Iir_Kind_Simple_Aggregate); - Set_Simple_Aggregate_List (Res, Get_Simple_Aggregate_List (Val)); - - when Iir_Kind_Overflow_Literal => - Res := Create_Iir (Iir_Kind_Overflow_Literal); - - when others => - Error_Kind ("build_constant", Val); - end case; - Location_Copy (Res, Origin); - Set_Type (Res, Get_Type (Origin)); - Set_Literal_Origin (Res, Origin); - Set_Expr_Staticness (Res, Locally); - return Res; - end Build_Constant; - - function Copy_Constant (Val : Iir) return Iir - is - Res : Iir; - begin - Res := Build_Constant (Val, Val); - Set_Literal_Origin (Res, Null_Iir); - return Res; - end Copy_Constant; - - -- FIXME: origin ? - function Build_Boolean (Cond : Boolean) return Iir is - begin - if Cond then - return Boolean_True; - else - return Boolean_False; - end if; - end Build_Boolean; - - function Build_Enumeration (Val : Iir_Index32; Origin : Iir) - return Iir_Enumeration_Literal - is - Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); - Enum_List : constant Iir_Flist := - Get_Enumeration_Literal_List (Enum_Type); - begin - return Get_Nth_Element (Enum_List, Integer (Val)); - end Build_Enumeration; - - function Build_Enumeration (Val : Boolean; Origin : Iir) - return Iir_Enumeration_Literal - is - Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); - Enum_List : constant Iir_Flist := - Get_Enumeration_Literal_List (Enum_Type); - begin - return Get_Nth_Element (Enum_List, Boolean'Pos (Val)); - end Build_Enumeration; - - function Build_Constant_Range (Range_Expr : Iir; Origin : Iir) return Iir - is - Res : Iir; - begin - Res := Create_Iir (Iir_Kind_Range_Expression); - Location_Copy (Res, Origin); - Set_Type (Res, Get_Type (Range_Expr)); - Set_Left_Limit (Res, Get_Left_Limit (Range_Expr)); - Set_Right_Limit (Res, Get_Right_Limit (Range_Expr)); - Set_Direction (Res, Get_Direction (Range_Expr)); - Set_Range_Origin (Res, Origin); - Set_Expr_Staticness (Res, Locally); - return Res; - end Build_Constant_Range; - - function Build_Extreme_Value (Is_Pos : Boolean; Origin : Iir) return Iir - is - Orig_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); - begin - case Get_Kind (Orig_Type) is - when Iir_Kind_Integer_Type_Definition => - if Is_Pos then - return Build_Integer (Iir_Int64'Last, Origin); - else - return Build_Integer (Iir_Int64'First, Origin); - end if; - when others => - Error_Kind ("build_extreme_value", Orig_Type); - end case; - end Build_Extreme_Value; - - -- A_RANGE is a range expression, whose type, location, expr_staticness, - -- left_limit and direction are set. - -- Type of A_RANGE must have a range_constraint. - -- Set the right limit of A_RANGE from LEN. - procedure Set_Right_Limit_By_Length (A_Range : Iir; Len : Iir_Int64) - is - A_Type : constant Iir := Get_Type (A_Range); - Left : constant Iir := Get_Left_Limit (A_Range); - Right : Iir; - Pos : Iir_Int64; - begin - pragma Assert (Get_Expr_Staticness (A_Range) = Locally); - - Pos := Eval_Pos (Left); - case Get_Direction (A_Range) is - when Iir_To => - Pos := Pos + Len - 1; - when Iir_Downto => - Pos := Pos - Len + 1; - end case; - if Len > 0 - and then not Eval_Int_In_Range (Pos, Get_Range_Constraint (A_Type)) - then - Error_Msg_Sem (+A_Range, "range length is beyond subtype length"); - Right := Left; - else - -- FIXME: what about nul range? - Right := Build_Discrete (Pos, A_Range); - Set_Literal_Origin (Right, Null_Iir); - Set_Right_Limit_Expr (A_Range, Right); - end if; - Set_Right_Limit (A_Range, Right); - end Set_Right_Limit_By_Length; - - -- Create a range of type A_TYPE whose length is LEN. - -- Note: only two nodes are created: - -- * the range_expression (node returned) - -- * the right bound - -- The left bound *IS NOT* created, but points to the left bound of A_TYPE. - function Create_Range_By_Length - (A_Type : Iir; Len : Iir_Int64; Loc : Location_Type) - return Iir - is - Index_Constraint : Iir; - Constraint : Iir; - begin - -- The left limit must be locally static in order to compute the right - -- limit. - pragma Assert (Get_Type_Staticness (A_Type) = Locally); - - Index_Constraint := Get_Range_Constraint (A_Type); - Constraint := Create_Iir (Iir_Kind_Range_Expression); - Set_Location (Constraint, Loc); - Set_Expr_Staticness (Constraint, Locally); - Set_Type (Constraint, A_Type); - Set_Left_Limit (Constraint, Get_Left_Limit (Index_Constraint)); - Set_Direction (Constraint, Get_Direction (Index_Constraint)); - Set_Right_Limit_By_Length (Constraint, Len); - return Constraint; - end Create_Range_By_Length; - - function Create_Range_Subtype_From_Type (A_Type : Iir; Loc : Location_Type) - return Iir - is - Res : Iir; - begin - pragma Assert (Get_Type_Staticness (A_Type) = Locally); - - case Get_Kind (A_Type) is - when Iir_Kind_Enumeration_Type_Definition => - Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - Res := Create_Iir (Get_Kind (A_Type)); - when others => - Error_Kind ("create_range_subtype_by_length", A_Type); - end case; - Set_Location (Res, Loc); - Set_Base_Type (Res, Get_Base_Type (A_Type)); - Set_Type_Staticness (Res, Locally); - - return Res; - end Create_Range_Subtype_From_Type; - - -- Create a subtype of A_TYPE whose length is LEN. - -- This is used to create subtypes for strings or aggregates. - function Create_Range_Subtype_By_Length - (A_Type : Iir; Len : Iir_Int64; Loc : Location_Type) - return Iir - is - Res : Iir; - begin - Res := Create_Range_Subtype_From_Type (A_Type, Loc); - - Set_Range_Constraint (Res, Create_Range_By_Length (A_Type, Len, Loc)); - return Res; - end Create_Range_Subtype_By_Length; - - function Create_Unidim_Array_From_Index - (Base_Type : Iir; Index_Type : Iir; Loc : Iir) - return Iir_Array_Subtype_Definition - is - Res : Iir_Array_Subtype_Definition; - begin - Res := Create_Array_Subtype (Base_Type, Get_Location (Loc)); - Set_Nth_Element (Get_Index_Subtype_List (Res), 0, Index_Type); - Set_Type_Staticness (Res, Min (Get_Type_Staticness (Res), - Get_Type_Staticness (Index_Type))); - Set_Constraint_State (Res, Fully_Constrained); - Set_Index_Constraint_Flag (Res, True); - return Res; - end Create_Unidim_Array_From_Index; - - function Create_Unidim_Array_By_Length - (Base_Type : Iir; Len : Iir_Int64; Loc : Iir) - return Iir_Array_Subtype_Definition - is - Index_Type : constant Iir := Get_Index_Type (Base_Type, 0); - N_Index_Type : Iir; - begin - N_Index_Type := Create_Range_Subtype_By_Length - (Index_Type, Len, Get_Location (Loc)); - return Create_Unidim_Array_From_Index (Base_Type, N_Index_Type, Loc); - end Create_Unidim_Array_By_Length; - - procedure Free_Eval_Static_Expr (Res : Iir; Orig : Iir) is - begin - if Res /= Orig and then Get_Literal_Origin (Res) = Orig then - Free_Iir (Res); - end if; - end Free_Eval_Static_Expr; - - -- Free the result RES of Eval_String_Literal called with ORIG, if created. - procedure Free_Eval_String_Literal (Res : Iir; Orig : Iir) - is - L : Iir_Flist; - begin - if Res /= Orig then - L := Get_Simple_Aggregate_List (Res); - Destroy_Iir_Flist (L); - Free_Iir (Res); - end if; - end Free_Eval_String_Literal; - - function String_Literal8_To_Simple_Aggregate (Str : Iir) return Iir - is - Element_Type : constant Iir := Get_Base_Type - (Get_Element_Subtype (Get_Base_Type (Get_Type (Str)))); - Literal_List : constant Iir_Flist := - Get_Enumeration_Literal_List (Element_Type); - - Len : constant Nat32 := Get_String_Length (Str); - Id : constant String8_Id := Get_String8_Id (Str); - - List : Iir_Flist; - Lit : Iir; - begin - List := Create_Iir_Flist (Natural (Len)); - - for I in 1 .. Len loop - Lit := Get_Nth_Element - (Literal_List, Natural (Str_Table.Element_String8 (Id, I))); - Set_Nth_Element (List, Natural (I - 1), Lit); - end loop; - return Build_Simple_Aggregate (List, Str, Get_Type (Str)); - end String_Literal8_To_Simple_Aggregate; - - -- Return the offset of EXPR in RNG. A result of 0 means the left bound, - -- a result of 1 mean the next element after the left bound. - -- Assume no overflow. - function Eval_Pos_In_Range (Rng : Iir; Expr : Iir) return Iir_Index32 - is - Left_Pos : constant Iir_Int64 := Eval_Pos (Get_Left_Limit (Rng)); - Pos : constant Iir_Int64 := Eval_Pos (Expr); - begin - case Get_Direction (Rng) is - when Iir_To => - return Iir_Index32 (Pos - Left_Pos); - when Iir_Downto => - return Iir_Index32 (Left_Pos - Pos); - end case; - end Eval_Pos_In_Range; - - procedure Build_Array_Choices_Vector - (Vect : out Iir_Array; Choice_Range : Iir; Choices_Chain : Iir) - is - pragma Assert (Vect'First = 0); - pragma Assert (Vect'Length = Eval_Discrete_Range_Length (Choice_Range)); - Assoc : Iir; - Choice : Iir; - Cur_Pos : Natural; - begin - -- Initialize Vect (to correctly handle 'others'). - Vect := (others => Null_Iir); - - Assoc := Choices_Chain; - Cur_Pos := 0; - Choice := Null_Iir; - while Is_Valid (Assoc) loop - if not Get_Same_Alternative_Flag (Assoc) then - Choice := Assoc; - end if; - case Iir_Kinds_Array_Choice (Get_Kind (Assoc)) is - when Iir_Kind_Choice_By_None => - Vect (Cur_Pos) := Choice; - Cur_Pos := Cur_Pos + 1; - when Iir_Kind_Choice_By_Range => - declare - Rng : constant Iir := Get_Choice_Range (Assoc); - Rng_Start : Iir; - Rng_Len : Iir_Int64; - begin - if Get_Direction (Rng) = Get_Direction (Choice_Range) then - Rng_Start := Get_Left_Limit (Rng); - else - Rng_Start := Get_Right_Limit (Rng); - end if; - Cur_Pos := Natural - (Eval_Pos_In_Range (Choice_Range, Rng_Start)); - Rng_Len := Eval_Discrete_Range_Length (Rng); - for I in 1 .. Rng_Len loop - Vect (Cur_Pos) := Choice; - Cur_Pos := Cur_Pos + 1; - end loop; - end; - when Iir_Kind_Choice_By_Expression => - Cur_Pos := Natural - (Eval_Pos_In_Range (Choice_Range, - Get_Choice_Expression (Assoc))); - Vect (Cur_Pos) := Choice; - when Iir_Kind_Choice_By_Others => - for I in Vect'Range loop - if Vect (I) = Null_Iir then - Vect (I) := Choice; - end if; - end loop; - end case; - Assoc := Get_Chain (Assoc); - end loop; - end Build_Array_Choices_Vector; - - function Aggregate_To_Simple_Aggregate (Aggr : Iir) return Iir - is - Aggr_Type : constant Iir := Get_Type (Aggr); - Index_Type : constant Iir := Get_Index_Type (Aggr_Type, 0); - Index_Range : constant Iir := Eval_Static_Range (Index_Type); - Len : constant Iir_Int64 := Eval_Discrete_Range_Length (Index_Range); - Assocs : constant Iir := Get_Association_Choices_Chain (Aggr); - Vect : Iir_Array (0 .. Integer (Len - 1)); - List : Iir_Flist; - Assoc : Iir; - Expr : Iir; - begin - Assoc := Assocs; - while Is_Valid (Assoc) loop - if not Get_Same_Alternative_Flag (Assoc) then - Expr := Get_Associated_Expr (Assoc); - if Get_Kind (Get_Type (Expr)) - in Iir_Kinds_Scalar_Type_And_Subtype_Definition - then - Expr := Eval_Expr_Keep_Orig (Expr, True); - Set_Associated_Expr (Assoc, Expr); - end if; - end if; - Assoc := Get_Chain (Assoc); - end loop; - - Build_Array_Choices_Vector (Vect, Index_Range, Assocs); - - List := Create_Iir_Flist (Natural (Len)); - if Len > 0 then - -- Workaround GNAT GPL2014 compiler bug. - for I in Vect'Range loop - Set_Nth_Element (List, I, Get_Associated_Expr (Vect (I))); - end loop; - end if; - - return Build_Simple_Aggregate (List, Aggr, Aggr_Type); - end Aggregate_To_Simple_Aggregate; - - function Eval_String_Literal (Str : Iir) return Iir is - begin - case Get_Kind (Str) is - when Iir_Kind_String_Literal8 => - return String_Literal8_To_Simple_Aggregate (Str); - - when Iir_Kind_Aggregate => - return Aggregate_To_Simple_Aggregate (Str); - - when Iir_Kind_Simple_Aggregate => - return Str; - - when others => - Error_Kind ("eval_string_literal", Str); - end case; - end Eval_String_Literal; - - function Eval_Monadic_Operator (Orig : Iir; Operand : Iir) return Iir - is - pragma Unsuppress (Overflow_Check); - subtype Iir_Predefined_Vector_Minmax is Iir_Predefined_Functions range - Iir_Predefined_Vector_Minimum .. Iir_Predefined_Vector_Maximum; - - Func : Iir_Predefined_Functions; - begin - if Get_Kind (Operand) = Iir_Kind_Overflow_Literal then - -- Propagate overflow. - return Build_Overflow (Orig); - end if; - - Func := Get_Implicit_Definition (Get_Implementation (Orig)); - case Func is - when Iir_Predefined_Integer_Negation => - return Build_Integer (-Get_Value (Operand), Orig); - when Iir_Predefined_Integer_Identity => - return Build_Integer (Get_Value (Operand), Orig); - when Iir_Predefined_Integer_Absolute => - return Build_Integer (abs Get_Value (Operand), Orig); - - when Iir_Predefined_Floating_Negation => - return Build_Floating (-Get_Fp_Value (Operand), Orig); - when Iir_Predefined_Floating_Identity => - return Build_Floating (Get_Fp_Value (Operand), Orig); - when Iir_Predefined_Floating_Absolute => - return Build_Floating (abs Get_Fp_Value (Operand), Orig); - - when Iir_Predefined_Physical_Negation => - return Build_Physical (-Get_Physical_Value (Operand), Orig); - when Iir_Predefined_Physical_Identity => - return Build_Physical (Get_Physical_Value (Operand), Orig); - when Iir_Predefined_Physical_Absolute => - return Build_Physical (abs Get_Physical_Value (Operand), Orig); - - when Iir_Predefined_Boolean_Not - | Iir_Predefined_Bit_Not => - return Build_Enumeration (Get_Enum_Pos (Operand) = 0, Orig); - - when Iir_Predefined_TF_Array_Not => - declare - Lit_Val : Iir; - O_List : Iir_Flist; - R_List : Iir_Flist; - El : Iir; - Lit : Iir; - begin - Lit_Val := Eval_String_Literal (Operand); - O_List := Get_Simple_Aggregate_List (Lit_Val); - R_List := Create_Iir_Flist (Get_Nbr_Elements (O_List)); - - for I in Flist_First .. Flist_Last (O_List) loop - El := Get_Nth_Element (O_List, I); - case Get_Enum_Pos (El) is - when 0 => - Lit := Bit_1; - when 1 => - Lit := Bit_0; - when others => - raise Internal_Error; - end case; - Set_Nth_Element (R_List, I, Lit); - end loop; - Free_Eval_String_Literal (Lit_Val, Operand); - return Build_Simple_Aggregate - (R_List, Orig, Get_Type (Operand)); - end; - - when Iir_Predefined_Enum_To_String => - return Eval_Enum_To_String (Operand, Orig); - when Iir_Predefined_Integer_To_String => - return Eval_Integer_Image (Get_Value (Operand), Orig); - - when Iir_Predefined_Array_Char_To_String => - -- LRM08 5.7 String representation - -- - For a given value that is of a one-dimensional array type - -- whose element type is a character type that contains only - -- character literals, the string representation has the same - -- length as the given value. Each element of the string - -- representation is the same character literal as the matching - -- element of the given value. - declare - Saggr : Iir; - Lits : Iir_Flist; - El : Iir; - C : Character; - String_Id : String8_Id; - Len : Natural; - begin - Saggr := Eval_String_Literal (Operand); - Lits := Get_Simple_Aggregate_List (Saggr); - Len := Get_Nbr_Elements (Lits); - String_Id := Str_Table.Create_String8; - for I in Flist_First .. Flist_Last (Lits) loop - El := Get_Nth_Element (Lits, I); - C := Get_Character (Get_Identifier (El)); - Str_Table.Append_String8_Char (C); - end loop; - Free_Eval_String_Literal (Saggr, Operand); - - return Build_String (String_Id, Nat32 (Len), Orig); - end; - - when Iir_Predefined_Vector_Minimum - | Iir_Predefined_Vector_Maximum => - -- LRM08 5.3.2.4 Predefined operations on array types - declare - Saggr : Iir; - Lits : Iir_Flist; - Res : Iir; - El : Iir; - Cmp : Compare_Type; - begin - Saggr := Eval_String_Literal (Operand); - Lits := Get_Simple_Aggregate_List (Saggr); - - if Get_Nbr_Elements (Lits) = 0 then - declare - Typ : constant Iir := - Get_Type (Get_Implementation (Orig)); - Rng : constant Iir := Eval_Static_Range (Typ); - begin - case Iir_Predefined_Vector_Minmax (Func) is - when Iir_Predefined_Vector_Minimum => - Res := Get_High_Limit (Rng); - when Iir_Predefined_Vector_Maximum => - Res := Get_Low_Limit (Rng); - end case; - Res := Eval_Static_Expr (Res); - end; - else - Res := Get_Nth_Element (Lits, 0); - for I in Flist_First .. Flist_Last (Lits) loop - El := Get_Nth_Element (Lits, I); - Cmp := Eval_Scalar_Compare (El, Res); - case Iir_Predefined_Vector_Minmax (Func) is - when Iir_Predefined_Vector_Minimum => - if Cmp <= Compare_Eq then - Res := El; - end if; - when Iir_Predefined_Vector_Maximum => - if Cmp >= Compare_Eq then - Res := El; - end if; - end case; - end loop; - end if; - Free_Eval_String_Literal (Saggr, Operand); - return Res; - end; - - when others => - Error_Internal (Orig, "eval_monadic_operator: " & - Iir_Predefined_Functions'Image (Func)); - end case; - exception - when Constraint_Error => - -- Can happen for absolute. - Warning_Msg_Sem (Warnid_Runtime_Error, +Orig, - "arithmetic overflow in static expression"); - return Build_Overflow (Orig); - end Eval_Monadic_Operator; - - function Eval_Dyadic_Bit_Array_Operator - (Expr : Iir; - Left, Right : Iir; - Func : Iir_Predefined_Dyadic_TF_Array_Functions) - return Iir - is - use Str_Table; - L_Str : constant String8_Id := Get_String8_Id (Left); - R_Str : constant String8_Id := Get_String8_Id (Right); - Len : Nat32; - Id : String8_Id; - Res : Iir; - begin - Len := Get_String_Length (Left); - if Len /= Get_String_Length (Right) then - Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, - "length of left and right operands mismatch"); - return Build_Overflow (Expr); - else - Id := Create_String8; - case Func is - when Iir_Predefined_TF_Array_And => - for I in 1 .. Len loop - case Element_String8 (L_Str, I) is - when 0 => - Append_String8 (0); - when 1 => - Append_String8 (Element_String8 (R_Str, I)); - when others => - raise Internal_Error; - end case; - end loop; - when Iir_Predefined_TF_Array_Nand => - for I in 1 .. Len loop - case Element_String8 (L_Str, I) is - when 0 => - Append_String8 (1); - when 1 => - case Element_String8 (R_Str, I) is - when 0 => - Append_String8 (1); - when 1 => - Append_String8 (0); - when others => - raise Internal_Error; - end case; - when others => - raise Internal_Error; - end case; - end loop; - when Iir_Predefined_TF_Array_Or => - for I in 1 .. Len loop - case Element_String8 (L_Str, I) is - when 1 => - Append_String8 (1); - when 0 => - Append_String8 (Element_String8 (R_Str, I)); - when others => - raise Internal_Error; - end case; - end loop; - when Iir_Predefined_TF_Array_Nor => - for I in 1 .. Len loop - case Element_String8 (L_Str, I) is - when 1 => - Append_String8 (0); - when 0 => - case Element_String8 (R_Str, I) is - when 0 => - Append_String8 (1); - when 1 => - Append_String8 (0); - when others => - raise Internal_Error; - end case; - when others => - raise Internal_Error; - end case; - end loop; - when Iir_Predefined_TF_Array_Xor => - for I in 1 .. Len loop - case Element_String8 (L_Str, I) is - when 1 => - case Element_String8 (R_Str, I) is - when 0 => - Append_String8 (1); - when 1 => - Append_String8 (0); - when others => - raise Internal_Error; - end case; - when 0 => - Append_String8 (Element_String8 (R_Str, I)); - when others => - raise Internal_Error; - end case; - end loop; - when others => - Error_Internal (Expr, "eval_dyadic_bit_array_functions: " & - Iir_Predefined_Functions'Image (Func)); - end case; - Res := Build_String (Id, Len, Expr); - - -- The unconstrained type is replaced by the constrained one. - Set_Type (Res, Get_Type (Left)); - return Res; - end if; - end Eval_Dyadic_Bit_Array_Operator; - - -- Return TRUE if VAL /= 0. - function Check_Integer_Division_By_Zero (Expr : Iir; Val : Iir) - return Boolean - is - begin - if Get_Value (Val) = 0 then - Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, "division by 0"); - return False; - else - return True; - end if; - end Check_Integer_Division_By_Zero; - - function Eval_Shift_Operator - (Left, Right : Iir; Origin : Iir; Func : Iir_Predefined_Shift_Functions) - return Iir - is - Count : constant Iir_Int64 := Get_Value (Right); - Arr_List : constant Iir_Flist := Get_Simple_Aggregate_List (Left); - Len : constant Natural := Get_Nbr_Elements (Arr_List); - Cnt : Natural; - Res_List : Iir_Flist; - Dir_Left : Boolean; - E : Iir; - begin - -- LRM93 7.2.3 - -- That is, if R is 0 or if L is a null array, the return value is L. - if Count = 0 or Len = 0 then - return Build_Simple_Aggregate (Arr_List, Origin, Get_Type (Left)); - end if; - case Func is - when Iir_Predefined_Array_Sll - | Iir_Predefined_Array_Sla - | Iir_Predefined_Array_Rol => - Dir_Left := True; - when Iir_Predefined_Array_Srl - | Iir_Predefined_Array_Sra - | Iir_Predefined_Array_Ror => - Dir_Left := False; - end case; - if Count < 0 then - Cnt := Natural (-Count); - Dir_Left := not Dir_Left; - else - Cnt := Natural (Count); - end if; - - case Func is - when Iir_Predefined_Array_Sll - | Iir_Predefined_Array_Srl => - declare - Enum_List : constant Iir_Flist := - Get_Enumeration_Literal_List - (Get_Base_Type (Get_Element_Subtype (Get_Type (Left)))); - begin - E := Get_Nth_Element (Enum_List, 0); - end; - when Iir_Predefined_Array_Sla - | Iir_Predefined_Array_Sra => - if Dir_Left then - E := Get_Nth_Element (Arr_List, Len - 1); - else - E := Get_Nth_Element (Arr_List, 0); - end if; - when Iir_Predefined_Array_Rol - | Iir_Predefined_Array_Ror => - Cnt := Cnt mod Len; - if not Dir_Left then - Cnt := (Len - Cnt) mod Len; - end if; - end case; - - Res_List := Create_Iir_Flist (Len); - - case Func is - when Iir_Predefined_Array_Sll - | Iir_Predefined_Array_Srl - | Iir_Predefined_Array_Sla - | Iir_Predefined_Array_Sra => - if Dir_Left then - if Cnt < Len then - for I in Cnt .. Len - 1 loop - Set_Nth_Element - (Res_List, I - Cnt, Get_Nth_Element (Arr_List, I)); - end loop; - else - Cnt := Len; - end if; - for I in 0 .. Cnt - 1 loop - Set_Nth_Element (Res_List, Len - Cnt + I, E); - end loop; - else - if Cnt > Len then - Cnt := Len; - end if; - for I in 0 .. Cnt - 1 loop - Set_Nth_Element (Res_List, I, E); - end loop; - for I in Cnt .. Len - 1 loop - Set_Nth_Element - (Res_List, I, Get_Nth_Element (Arr_List, I - Cnt)); - end loop; - end if; - when Iir_Predefined_Array_Rol - | Iir_Predefined_Array_Ror => - for I in 1 .. Len loop - Set_Nth_Element - (Res_List, I - 1, Get_Nth_Element (Arr_List, Cnt)); - Cnt := Cnt + 1; - if Cnt = Len then - Cnt := 0; - end if; - end loop; - end case; - return Build_Simple_Aggregate (Res_List, Origin, Get_Type (Left)); - end Eval_Shift_Operator; - - -- Note: operands must be locally static. - function Eval_Concatenation - (Left, Right : Iir; Orig : Iir; Func : Iir_Predefined_Concat_Functions) - return Iir - is - Res_List : Iir_Flist; - Res_Len : Natural; - Res_Type : Iir; - Origin_Type : Iir; - Left_Aggr, Right_Aggr : Iir; - Left_List, Right_List : Iir_Flist; - Left_Len, Right_Len : Natural; - begin - -- Compute length of the result. - -- Left: - case Func is - when Iir_Predefined_Element_Array_Concat - | Iir_Predefined_Element_Element_Concat => - Left_Len := 1; - when Iir_Predefined_Array_Element_Concat - | Iir_Predefined_Array_Array_Concat => - Left_Aggr := Eval_String_Literal (Left); - Left_List := Get_Simple_Aggregate_List (Left_Aggr); - Left_Len := Get_Nbr_Elements (Left_List); - end case; - -- Right: - case Func is - when Iir_Predefined_Array_Element_Concat - | Iir_Predefined_Element_Element_Concat => - Right_Len := 1; - when Iir_Predefined_Element_Array_Concat - | Iir_Predefined_Array_Array_Concat => - Right_Aggr := Eval_String_Literal (Right); - Right_List := Get_Simple_Aggregate_List (Right_Aggr); - Right_Len := Get_Nbr_Elements (Right_List); - end case; - - Res_Len := Left_Len + Right_Len; - Res_List := Create_Iir_Flist (Res_Len); - -- Do the concatenation. - -- Left: - case Func is - when Iir_Predefined_Element_Array_Concat - | Iir_Predefined_Element_Element_Concat => - Set_Nth_Element (Res_List, 0, Left); - when Iir_Predefined_Array_Element_Concat - | Iir_Predefined_Array_Array_Concat => - for I in 0 .. Left_Len - 1 loop - Set_Nth_Element (Res_List, I, Get_Nth_Element (Left_List, I)); - end loop; - Free_Eval_String_Literal (Left_Aggr, Left); - end case; - -- Right: - case Func is - when Iir_Predefined_Array_Element_Concat - | Iir_Predefined_Element_Element_Concat => - Set_Nth_Element (Res_List, Left_Len, Right); - when Iir_Predefined_Element_Array_Concat - | Iir_Predefined_Array_Array_Concat => - for I in 0 .. Right_Len - 1 loop - Set_Nth_Element - (Res_List, Left_Len + I, Get_Nth_Element (Right_List, I)); - end loop; - Free_Eval_String_Literal (Right_Aggr, Right); - end case; - - -- Compute subtype... - Origin_Type := Get_Type (Orig); - Res_Type := Null_Iir; - if Func = Iir_Predefined_Array_Array_Concat - and then Left_Len = 0 - then - if Flags.Vhdl_Std = Vhdl_87 then - -- LRM87 7.2.3 - -- [...], unless the left operand is a null array, in which case - -- the result of the concatenation is the right operand. - Res_Type := Get_Type (Right); - else - -- LRM93 7.2.4 - -- If both operands are null arrays, then the result of the - -- concatenation is the right operand. - if Get_Nbr_Elements (Right_List) = 0 then - Res_Type := Get_Type (Right); - end if; - end if; - end if; - if Res_Type = Null_Iir then - if Flags.Vhdl_Std = Vhdl_87 - and then (Func = Iir_Predefined_Array_Array_Concat - or Func = Iir_Predefined_Array_Element_Concat) - then - -- LRM87 7.2.3 - -- The left bound of the result is the left operand, [...] - -- - -- LRM87 7.2.3 - -- The direction of the result is the direction of the left - -- operand, [...] - declare - Left_Index : constant Iir := - Get_Index_Type (Get_Type (Left), 0); - Left_Range : constant Iir := - Get_Range_Constraint (Left_Index); - Ret_Type : constant Iir := - Get_Return_Type (Get_Implementation (Orig)); - A_Range : Iir; - Index_Type : Iir; - begin - A_Range := Create_Iir (Iir_Kind_Range_Expression); - Set_Type (A_Range, Get_Index_Type (Ret_Type, 0)); - Set_Expr_Staticness (A_Range, Locally); - Set_Left_Limit (A_Range, Get_Left_Limit (Left_Range)); - Set_Direction (A_Range, Get_Direction (Left_Range)); - Location_Copy (A_Range, Orig); - Set_Right_Limit_By_Length (A_Range, Iir_Int64 (Res_Len)); - Index_Type := Create_Range_Subtype_From_Type - (Left_Index, Get_Location (Orig)); - Set_Range_Constraint (Index_Type, A_Range); - Res_Type := Create_Unidim_Array_From_Index - (Origin_Type, Index_Type, Orig); - end; - else - -- LRM93 7.2.4 - -- Otherwise, the direction and bounds of the result are - -- determined as follows: let S be the index subtype of the base - -- type of the result. The direction of the result of the - -- concatenation is the direction of S, and the left bound of the - -- result is S'LEFT. - Res_Type := Create_Unidim_Array_By_Length - (Origin_Type, Iir_Int64 (Res_Len), Orig); - end if; - end if; - -- FIXME: this is not necessarily a string, it may be an aggregate if - -- element type is not a character type. - return Build_Simple_Aggregate (Res_List, Orig, Res_Type, Res_Type); - end Eval_Concatenation; - - function Eval_Scalar_Compare (Left, Right : Iir) return Compare_Type - is - Ltype : constant Iir := Get_Base_Type (Get_Type (Left)); - begin - pragma Assert - (Get_Kind (Ltype) = Get_Kind (Get_Base_Type (Get_Type (Right)))); - - case Get_Kind (Ltype) is - when Iir_Kind_Enumeration_Type_Definition => - declare - L_Pos : constant Iir_Int32 := Get_Enum_Pos (Left); - R_Pos : constant Iir_Int32 := Get_Enum_Pos (Right); - begin - if L_Pos = R_Pos then - return Compare_Eq; - else - if L_Pos < R_Pos then - return Compare_Lt; - else - return Compare_Gt; - end if; - end if; - end; - when Iir_Kind_Physical_Type_Definition => - declare - L_Val : constant Iir_Int64 := Get_Physical_Value (Left); - R_Val : constant Iir_Int64 := Get_Physical_Value (Right); - begin - if L_Val = R_Val then - return Compare_Eq; - else - if L_Val < R_Val then - return Compare_Lt; - else - return Compare_Gt; - end if; - end if; - end; - when Iir_Kind_Integer_Type_Definition => - declare - L_Val : constant Iir_Int64 := Get_Value (Left); - R_Val : constant Iir_Int64 := Get_Value (Right); - begin - if L_Val = R_Val then - return Compare_Eq; - else - if L_Val < R_Val then - return Compare_Lt; - else - return Compare_Gt; - end if; - end if; - end; - when Iir_Kind_Floating_Type_Definition => - declare - L_Val : constant Iir_Fp64 := Get_Fp_Value (Left); - R_Val : constant Iir_Fp64 := Get_Fp_Value (Right); - begin - if L_Val = R_Val then - return Compare_Eq; - else - if L_Val < R_Val then - return Compare_Lt; - else - return Compare_Gt; - end if; - end if; - end; - when others => - Error_Kind ("eval_scalar_compare", Ltype); - end case; - end Eval_Scalar_Compare; - - function Eval_Array_Compare (Left, Right : Iir) return Compare_Type is - begin - if Get_Kind (Left) = Iir_Kind_String_Literal8 - and then Get_Kind (Right) = Iir_Kind_String_Literal8 - then - -- Common case: both parameters are strings. - declare - L_Id : constant String8_Id := Get_String8_Id (Left); - R_Id : constant String8_Id := Get_String8_Id (Right); - L_Len : constant Int32 := Get_String_Length (Left); - R_Len : constant Int32 := Get_String_Length (Right); - L_El, R_El : Nat8; - P : Nat32; - begin - P := 1; - while P <= L_Len and P <= R_Len loop - L_El := Str_Table.Element_String8 (L_Id, P); - R_El := Str_Table.Element_String8 (R_Id, P); - if L_El /= R_El then - if L_El < R_El then - return Compare_Lt; - else - return Compare_Gt; - end if; - end if; - P := P + 1; - end loop; - if L_Len = R_Len then - return Compare_Eq; - elsif L_Len < R_Len then - return Compare_Lt; - else - return Compare_Gt; - end if; - end; - else - -- General case. - declare - Left_Val, Right_Val : Iir; - R_List, L_List : Iir_Flist; - R_Len, L_Len : Natural; - P : Natural; - Res : Compare_Type; - begin - Left_Val := Eval_String_Literal (Left); - Right_Val := Eval_String_Literal (Right); - - L_List := Get_Simple_Aggregate_List (Left_Val); - R_List := Get_Simple_Aggregate_List (Right_Val); - L_Len := Get_Nbr_Elements (L_List); - R_Len := Get_Nbr_Elements (R_List); - - Res := Compare_Eq; - P := 0; - while P < L_Len and P < R_Len loop - Res := Eval_Scalar_Compare (Get_Nth_Element (L_List, P), - Get_Nth_Element (R_List, P)); - exit when Res /= Compare_Eq; - P := P + 1; - end loop; - if Res = Compare_Eq then - if L_Len < R_Len then - Res := Compare_Lt; - elsif L_Len > R_Len then - Res := Compare_Gt; - end if; - end if; - - Free_Eval_Static_Expr (Left_Val, Left); - Free_Eval_Static_Expr (Right_Val, Right); - - return Res; - end; - end if; - end Eval_Array_Compare; - - -- ORIG is either a dyadic operator or a function call. - function Eval_Dyadic_Operator (Orig : Iir; Imp : Iir; Left, Right : Iir) - return Iir - is - pragma Unsuppress (Overflow_Check); - Func : constant Iir_Predefined_Functions := - Get_Implicit_Definition (Imp); - begin - if Get_Kind (Left) = Iir_Kind_Overflow_Literal - or else Get_Kind (Right) = Iir_Kind_Overflow_Literal - then - return Build_Overflow (Orig); - end if; - - case Func is - when Iir_Predefined_Integer_Plus => - return Build_Integer (Get_Value (Left) + Get_Value (Right), Orig); - when Iir_Predefined_Integer_Minus => - return Build_Integer (Get_Value (Left) - Get_Value (Right), Orig); - when Iir_Predefined_Integer_Mul => - return Build_Integer (Get_Value (Left) * Get_Value (Right), Orig); - when Iir_Predefined_Integer_Div => - if Check_Integer_Division_By_Zero (Orig, Right) then - return Build_Integer - (Get_Value (Left) / Get_Value (Right), Orig); - else - return Build_Overflow (Orig); - end if; - when Iir_Predefined_Integer_Mod => - if Check_Integer_Division_By_Zero (Orig, Right) then - return Build_Integer - (Get_Value (Left) mod Get_Value (Right), Orig); - else - return Build_Overflow (Orig); - end if; - when Iir_Predefined_Integer_Rem => - if Check_Integer_Division_By_Zero (Orig, Right) then - return Build_Integer - (Get_Value (Left) rem Get_Value (Right), Orig); - else - return Build_Overflow (Orig); - end if; - when Iir_Predefined_Integer_Exp => - return Build_Integer - (Get_Value (Left) ** Integer (Get_Value (Right)), Orig); - - when Iir_Predefined_Integer_Equality => - return Build_Boolean (Get_Value (Left) = Get_Value (Right)); - when Iir_Predefined_Integer_Inequality => - return Build_Boolean (Get_Value (Left) /= Get_Value (Right)); - when Iir_Predefined_Integer_Greater_Equal => - return Build_Boolean (Get_Value (Left) >= Get_Value (Right)); - when Iir_Predefined_Integer_Greater => - return Build_Boolean (Get_Value (Left) > Get_Value (Right)); - when Iir_Predefined_Integer_Less_Equal => - return Build_Boolean (Get_Value (Left) <= Get_Value (Right)); - when Iir_Predefined_Integer_Less => - return Build_Boolean (Get_Value (Left) < Get_Value (Right)); - - when Iir_Predefined_Integer_Minimum => - if Get_Value (Left) < Get_Value (Right) then - return Left; - else - return Right; - end if; - when Iir_Predefined_Integer_Maximum => - if Get_Value (Left) > Get_Value (Right) then - return Left; - else - return Right; - end if; - - when Iir_Predefined_Floating_Equality => - return Build_Boolean (Get_Fp_Value (Left) = Get_Fp_Value (Right)); - when Iir_Predefined_Floating_Inequality => - return Build_Boolean (Get_Fp_Value (Left) /= Get_Fp_Value (Right)); - when Iir_Predefined_Floating_Greater => - return Build_Boolean (Get_Fp_Value (Left) > Get_Fp_Value (Right)); - when Iir_Predefined_Floating_Greater_Equal => - return Build_Boolean (Get_Fp_Value (Left) >= Get_Fp_Value (Right)); - when Iir_Predefined_Floating_Less => - return Build_Boolean (Get_Fp_Value (Left) < Get_Fp_Value (Right)); - when Iir_Predefined_Floating_Less_Equal => - return Build_Boolean (Get_Fp_Value (Left) <= Get_Fp_Value (Right)); - - when Iir_Predefined_Floating_Minus => - return Build_Floating - (Get_Fp_Value (Left) - Get_Fp_Value (Right), Orig); - when Iir_Predefined_Floating_Plus => - return Build_Floating - (Get_Fp_Value (Left) + Get_Fp_Value (Right), Orig); - when Iir_Predefined_Floating_Mul => - return Build_Floating - (Get_Fp_Value (Left) * Get_Fp_Value (Right), Orig); - when Iir_Predefined_Floating_Div => - if Get_Fp_Value (Right) = 0.0 then - Warning_Msg_Sem (Warnid_Runtime_Error, +Orig, - "right operand of division is 0"); - return Build_Overflow (Orig); - else - return Build_Floating - (Get_Fp_Value (Left) / Get_Fp_Value (Right), Orig); - end if; - when Iir_Predefined_Floating_Exp => - declare - Exp : Iir_Int64; - Res : Iir_Fp64; - Val : Iir_Fp64; - begin - Res := 1.0; - Val := Get_Fp_Value (Left); - -- LRM08 9.2.8 Misellaneous operators - -- Exponentiation with an integer exponent is equivalent to - -- repeated multiplication of the left operand by itself for - -- a number of times indicated by the absolute value of the - -- exponent and from left to right; [...] - -- GHDL: use the standard power-of-2 approach. This is not - -- strictly equivalent however. - Exp := abs Get_Value (Right); - while Exp /= 0 loop - if Exp mod 2 = 1 then - Res := Res * Val; - end if; - Exp := Exp / 2; - Val := Val * Val; - end loop; - -- LRM08 9.2.8 Misellaneous operators - -- [...] if the exponent is negative then the result is the - -- reciprocal of that [...] - if Get_Value (Right) < 0 then - Res := 1.0 / Res; - end if; - return Build_Floating (Res, Orig); - end; - - when Iir_Predefined_Floating_Minimum => - if Get_Fp_Value (Left) < Get_Fp_Value (Right) then - return Left; - else - return Right; - end if; - when Iir_Predefined_Floating_Maximum => - if Get_Fp_Value (Left) > Get_Fp_Value (Right) then - return Left; - else - return Right; - end if; - - when Iir_Predefined_Physical_Equality => - return Build_Boolean - (Get_Physical_Value (Left) = Get_Physical_Value (Right)); - when Iir_Predefined_Physical_Inequality => - return Build_Boolean - (Get_Physical_Value (Left) /= Get_Physical_Value (Right)); - when Iir_Predefined_Physical_Greater_Equal => - return Build_Boolean - (Get_Physical_Value (Left) >= Get_Physical_Value (Right)); - when Iir_Predefined_Physical_Greater => - return Build_Boolean - (Get_Physical_Value (Left) > Get_Physical_Value (Right)); - when Iir_Predefined_Physical_Less_Equal => - return Build_Boolean - (Get_Physical_Value (Left) <= Get_Physical_Value (Right)); - when Iir_Predefined_Physical_Less => - return Build_Boolean - (Get_Physical_Value (Left) < Get_Physical_Value (Right)); - - when Iir_Predefined_Physical_Physical_Div => - return Build_Integer - (Get_Physical_Value (Left) / Get_Physical_Value (Right), Orig); - when Iir_Predefined_Physical_Integer_Div => - return Build_Physical - (Get_Physical_Value (Left) / Get_Value (Right), Orig); - when Iir_Predefined_Physical_Minus => - return Build_Physical - (Get_Physical_Value (Left) - Get_Physical_Value (Right), Orig); - when Iir_Predefined_Physical_Plus => - return Build_Physical - (Get_Physical_Value (Left) + Get_Physical_Value (Right), Orig); - when Iir_Predefined_Integer_Physical_Mul => - return Build_Physical - (Get_Value (Left) * Get_Physical_Value (Right), Orig); - when Iir_Predefined_Physical_Integer_Mul => - return Build_Physical - (Get_Physical_Value (Left) * Get_Value (Right), Orig); - when Iir_Predefined_Real_Physical_Mul => - -- FIXME: overflow?? - return Build_Physical - (Iir_Int64 (Get_Fp_Value (Left) - * Iir_Fp64 (Get_Physical_Value (Right))), Orig); - when Iir_Predefined_Physical_Real_Mul => - -- FIXME: overflow?? - return Build_Physical - (Iir_Int64 (Iir_Fp64 (Get_Physical_Value (Left)) - * Get_Fp_Value (Right)), Orig); - when Iir_Predefined_Physical_Real_Div => - -- FIXME: overflow?? - return Build_Physical - (Iir_Int64 (Iir_Fp64 (Get_Physical_Value (Left)) - / Get_Fp_Value (Right)), Orig); - - when Iir_Predefined_Physical_Minimum => - return Build_Physical (Iir_Int64'Min (Get_Physical_Value (Left), - Get_Physical_Value (Right)), - Orig); - when Iir_Predefined_Physical_Maximum => - return Build_Physical (Iir_Int64'Max (Get_Physical_Value (Left), - Get_Physical_Value (Right)), - Orig); - - when Iir_Predefined_Element_Array_Concat - | Iir_Predefined_Array_Element_Concat - | Iir_Predefined_Array_Array_Concat - | Iir_Predefined_Element_Element_Concat => - return Eval_Concatenation (Left, Right, Orig, Func); - - when Iir_Predefined_Enum_Equality - | Iir_Predefined_Bit_Match_Equality => - return Build_Enumeration - (Get_Enum_Pos (Left) = Get_Enum_Pos (Right), Orig); - when Iir_Predefined_Enum_Inequality - | Iir_Predefined_Bit_Match_Inequality => - return Build_Enumeration - (Get_Enum_Pos (Left) /= Get_Enum_Pos (Right), Orig); - when Iir_Predefined_Enum_Greater_Equal - | Iir_Predefined_Bit_Match_Greater_Equal => - return Build_Enumeration - (Get_Enum_Pos (Left) >= Get_Enum_Pos (Right), Orig); - when Iir_Predefined_Enum_Greater - | Iir_Predefined_Bit_Match_Greater => - return Build_Enumeration - (Get_Enum_Pos (Left) > Get_Enum_Pos (Right), Orig); - when Iir_Predefined_Enum_Less_Equal - | Iir_Predefined_Bit_Match_Less_Equal => - return Build_Enumeration - (Get_Enum_Pos (Left) <= Get_Enum_Pos (Right), Orig); - when Iir_Predefined_Enum_Less - | Iir_Predefined_Bit_Match_Less => - return Build_Enumeration - (Get_Enum_Pos (Left) < Get_Enum_Pos (Right), Orig); - - when Iir_Predefined_Enum_Minimum => - if Get_Enum_Pos (Left) < Get_Enum_Pos (Right) then - return Left; - else - return Right; - end if; - when Iir_Predefined_Enum_Maximum => - if Get_Enum_Pos (Left) > Get_Enum_Pos (Right) then - return Left; - else - return Right; - end if; - - when Iir_Predefined_Boolean_And - | Iir_Predefined_Bit_And => - return Build_Enumeration - (Get_Enum_Pos (Left) = 1 and Get_Enum_Pos (Right) = 1, Orig); - when Iir_Predefined_Boolean_Nand - | Iir_Predefined_Bit_Nand => - return Build_Enumeration - (not (Get_Enum_Pos (Left) = 1 and Get_Enum_Pos (Right) = 1), - Orig); - when Iir_Predefined_Boolean_Or - | Iir_Predefined_Bit_Or => - return Build_Enumeration - (Get_Enum_Pos (Left) = 1 or Get_Enum_Pos (Right) = 1, Orig); - when Iir_Predefined_Boolean_Nor - | Iir_Predefined_Bit_Nor => - return Build_Enumeration - (not (Get_Enum_Pos (Left) = 1 or Get_Enum_Pos (Right) = 1), - Orig); - when Iir_Predefined_Boolean_Xor - | Iir_Predefined_Bit_Xor => - return Build_Enumeration - (Get_Enum_Pos (Left) = 1 xor Get_Enum_Pos (Right) = 1, Orig); - when Iir_Predefined_Boolean_Xnor - | Iir_Predefined_Bit_Xnor => - return Build_Enumeration - (not (Get_Enum_Pos (Left) = 1 xor Get_Enum_Pos (Right) = 1), - Orig); - - when Iir_Predefined_Dyadic_TF_Array_Functions => - -- FIXME: only for bit ? - return Eval_Dyadic_Bit_Array_Operator (Orig, Left, Right, Func); - - when Iir_Predefined_Universal_R_I_Mul => - return Build_Floating - (Get_Fp_Value (Left) * Iir_Fp64 (Get_Value (Right)), Orig); - when Iir_Predefined_Universal_I_R_Mul => - return Build_Floating - (Iir_Fp64 (Get_Value (Left)) * Get_Fp_Value (Right), Orig); - when Iir_Predefined_Universal_R_I_Div => - return Build_Floating - (Get_Fp_Value (Left) / Iir_Fp64 (Get_Value (Right)), Orig); - - when Iir_Predefined_Array_Sll - | Iir_Predefined_Array_Srl - | Iir_Predefined_Array_Sla - | Iir_Predefined_Array_Sra - | Iir_Predefined_Array_Rol - | Iir_Predefined_Array_Ror => - declare - Left_Aggr : Iir; - Res : Iir; - begin - Left_Aggr := Eval_String_Literal (Left); - Res := Eval_Shift_Operator (Left_Aggr, Right, Orig, Func); - Free_Eval_String_Literal (Left_Aggr, Left); - return Res; - end; - - when Iir_Predefined_Array_Equality => - return Build_Boolean - (Eval_Array_Compare (Left, Right) = Compare_Eq); - when Iir_Predefined_Array_Inequality => - return Build_Boolean - (Eval_Array_Compare (Left, Right) /= Compare_Eq); - when Iir_Predefined_Array_Less => - return Build_Boolean - (Eval_Array_Compare (Left, Right) = Compare_Lt); - when Iir_Predefined_Array_Less_Equal => - return Build_Boolean - (Eval_Array_Compare (Left, Right) <= Compare_Eq); - when Iir_Predefined_Array_Greater => - return Build_Boolean - (Eval_Array_Compare (Left, Right) = Compare_Gt); - when Iir_Predefined_Array_Greater_Equal => - return Build_Boolean - (Eval_Array_Compare (Left, Right) >= Compare_Eq); - - when Iir_Predefined_Boolean_Not - | Iir_Predefined_Boolean_Rising_Edge - | Iir_Predefined_Boolean_Falling_Edge - | Iir_Predefined_Bit_Not - | Iir_Predefined_Bit_Rising_Edge - | Iir_Predefined_Bit_Falling_Edge - | Iir_Predefined_Integer_Absolute - | Iir_Predefined_Integer_Identity - | Iir_Predefined_Integer_Negation - | Iir_Predefined_Floating_Absolute - | Iir_Predefined_Floating_Negation - | Iir_Predefined_Floating_Identity - | Iir_Predefined_Physical_Absolute - | Iir_Predefined_Physical_Identity - | Iir_Predefined_Physical_Negation - | Iir_Predefined_Error - | Iir_Predefined_Record_Equality - | Iir_Predefined_Record_Inequality - | Iir_Predefined_Access_Equality - | Iir_Predefined_Access_Inequality - | Iir_Predefined_TF_Array_Not - | Iir_Predefined_Now_Function - | Iir_Predefined_Deallocate - | Iir_Predefined_Write - | Iir_Predefined_Read - | Iir_Predefined_Read_Length - | Iir_Predefined_Flush - | Iir_Predefined_File_Open - | Iir_Predefined_File_Open_Status - | Iir_Predefined_File_Close - | Iir_Predefined_Endfile - | Iir_Predefined_Array_Char_To_String - | Iir_Predefined_Bit_Vector_To_Ostring - | Iir_Predefined_Bit_Vector_To_Hstring => - -- Not binary or never locally static. - Error_Internal (Orig, "eval_dyadic_operator: " & - Iir_Predefined_Functions'Image (Func)); - - when Iir_Predefined_Bit_Condition => - raise Internal_Error; - - when Iir_Predefined_Array_Minimum - | Iir_Predefined_Array_Maximum - | Iir_Predefined_Vector_Minimum - | Iir_Predefined_Vector_Maximum => - raise Internal_Error; - - when Iir_Predefined_Std_Ulogic_Match_Equality - | Iir_Predefined_Std_Ulogic_Match_Inequality - | Iir_Predefined_Std_Ulogic_Match_Less - | Iir_Predefined_Std_Ulogic_Match_Less_Equal - | Iir_Predefined_Std_Ulogic_Match_Greater - | Iir_Predefined_Std_Ulogic_Match_Greater_Equal => - -- TODO - raise Internal_Error; - - when Iir_Predefined_Enum_To_String - | Iir_Predefined_Integer_To_String - | Iir_Predefined_Floating_To_String - | Iir_Predefined_Real_To_String_Digits - | Iir_Predefined_Real_To_String_Format - | Iir_Predefined_Physical_To_String - | Iir_Predefined_Time_To_String_Unit => - -- TODO - raise Internal_Error; - - when Iir_Predefined_TF_Array_Element_And - | Iir_Predefined_TF_Element_Array_And - | Iir_Predefined_TF_Array_Element_Or - | Iir_Predefined_TF_Element_Array_Or - | Iir_Predefined_TF_Array_Element_Nand - | Iir_Predefined_TF_Element_Array_Nand - | Iir_Predefined_TF_Array_Element_Nor - | Iir_Predefined_TF_Element_Array_Nor - | Iir_Predefined_TF_Array_Element_Xor - | Iir_Predefined_TF_Element_Array_Xor - | Iir_Predefined_TF_Array_Element_Xnor - | Iir_Predefined_TF_Element_Array_Xnor => - -- TODO - raise Internal_Error; - - when Iir_Predefined_TF_Reduction_And - | Iir_Predefined_TF_Reduction_Or - | Iir_Predefined_TF_Reduction_Nand - | Iir_Predefined_TF_Reduction_Nor - | Iir_Predefined_TF_Reduction_Xor - | Iir_Predefined_TF_Reduction_Xnor - | Iir_Predefined_TF_Reduction_Not => - -- TODO - raise Internal_Error; - - when Iir_Predefined_Bit_Array_Match_Equality - | Iir_Predefined_Bit_Array_Match_Inequality - | Iir_Predefined_Std_Ulogic_Array_Match_Equality - | Iir_Predefined_Std_Ulogic_Array_Match_Inequality => - -- TODO - raise Internal_Error; - - when Iir_Predefined_Explicit => - raise Internal_Error; - end case; - exception - when Constraint_Error => - Warning_Msg_Sem (Warnid_Runtime_Error, +Orig, - "arithmetic overflow in static expression"); - return Build_Overflow (Orig); - end Eval_Dyadic_Operator; - - -- Get the parameter of an attribute, or 1 if doesn't exist. - function Eval_Attribute_Parameter_Or_1 (Attr : Iir) return Natural - is - Parameter : constant Iir := Get_Parameter (Attr); - begin - if Is_Null (Parameter) or else Is_Error (Parameter) then - return 1; - else - return Natural (Get_Value (Parameter)); - end if; - end Eval_Attribute_Parameter_Or_1; - - -- Evaluate any array attribute, return the type for the prefix. - function Eval_Array_Attribute (Attr : Iir) return Iir - is - Prefix : Iir; - Prefix_Type : Iir; - Dim : Natural; - begin - Prefix := Get_Prefix (Attr); - case Get_Kind (Prefix) is - when Iir_Kinds_Object_Declaration -- FIXME: remove - | Iir_Kind_Selected_Element - | Iir_Kind_Indexed_Name - | Iir_Kind_Slice_Name - | Iir_Kind_Subtype_Declaration - | Iir_Kind_Type_Declaration - | Iir_Kind_Implicit_Dereference - | Iir_Kind_Function_Call - | Iir_Kind_Attribute_Value - | Iir_Kind_Attribute_Name - | Iir_Kind_Subtype_Attribute => - Prefix_Type := Get_Type (Prefix); - when Iir_Kinds_Subtype_Definition => - Prefix_Type := Prefix; - when Iir_Kinds_Denoting_Name => - Prefix_Type := Get_Type (Prefix); - when others => - Error_Kind ("eval_array_attribute", Prefix); - end case; - if Get_Kind (Prefix_Type) /= Iir_Kind_Array_Subtype_Definition then - Error_Kind ("eval_array_attribute(2)", Prefix_Type); - end if; - - Dim := Eval_Attribute_Parameter_Or_1 (Attr); - return Get_Nth_Element (Get_Index_Subtype_List (Prefix_Type), Dim - 1); - end Eval_Array_Attribute; - - function Eval_Integer_Image (Val : Iir_Int64; Orig : Iir) return Iir - is - use Str_Table; - Img : String (1 .. 24); -- 23 is enough, 24 is rounded. - L : Natural; - V : Iir_Int64; - Id : String8_Id; - begin - V := Val; - L := Img'Last; - loop - Img (L) := Character'Val (Character'Pos ('0') + abs (V rem 10)); - V := V / 10; - L := L - 1; - exit when V = 0; - end loop; - if Val < 0 then - Img (L) := '-'; - L := L - 1; - end if; - Id := Create_String8; - for I in L + 1 .. Img'Last loop - Append_String8_Char (Img (I)); - end loop; - return Build_String (Id, Nat32 (Img'Last - L), Orig); - end Eval_Integer_Image; - - function Eval_Floating_Image (Val : Iir_Fp64; Orig : Iir) return Iir - is - use Str_Table; - Id : String8_Id; - - -- Sign (1) + digit (1) + dot (1) + digits (15) + 'e' (1) + sign (1) - -- + exp_digits (4) -> 24. - Str : String (1 .. 25); - P : Natural; - - Res : Iir; - begin - P := Str'First; - - Grt.Fcvt.Format_Image (Str, P, Interfaces.IEEE_Float_64 (Val)); - - Id := Create_String8; - for I in 1 .. P loop - Append_String8_Char (Str (I)); - end loop; - Res := Build_String (Id, Int32 (P), Orig); - -- FIXME: this is not correct since the type is *not* constrained. - Set_Type (Res, Create_Unidim_Array_By_Length - (Get_Type (Orig), Iir_Int64 (P), Orig)); - return Res; - end Eval_Floating_Image; - - function Eval_Enumeration_Image (Lit : Iir; Orig : Iir) return Iir - is - use Str_Table; - Name : constant String := Image_Identifier (Lit); - Image_Id : constant String8_Id := Str_Table.Create_String8; - begin - Append_String8_String (Name); - return Build_String (Image_Id, Name'Length, Orig); - end Eval_Enumeration_Image; - - function Build_Enumeration_Value (Val : String; Enum, Expr : Iir) return Iir - is - List : constant Iir_Flist := Get_Enumeration_Literal_List (Enum); - Value : String (Val'range); - Id : Name_Id; - Res : Iir; - begin - if Val'Length = 3 - and then Val (Val'First) = ''' and then Val (Val'Last) = ''' - then - -- A single character. - Id := Get_Identifier (Val (Val'First + 1)); - else - for I in Val'range loop - Value (I) := Ada.Characters.Handling.To_Lower (Val (I)); - end loop; - Id := Get_Identifier (Value); - end if; - Res := Find_Name_In_Flist (List, Id); - if Res /= Null_Iir then - return Build_Constant (Res, Expr); - else - Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, - "value %i not in enumeration %n", (+Id, +Enum)); - return Build_Overflow (Expr); - end if; - end Build_Enumeration_Value; - - function Eval_Physical_Image (Phys, Expr: Iir) return Iir - is - -- Reduces to the base unit (e.g. femtoseconds). - Value : constant String := Iir_Int64'Image (Get_Physical_Value (Phys)); - Unit : constant Iir := - Get_Primary_Unit (Get_Base_Type (Get_Type (Phys))); - UnitName : constant String := Image_Identifier (Unit); - Image_Id : constant String8_Id := Str_Table.Create_String8; - Length : Nat32 := Value'Length + UnitName'Length + 1; - begin - for I in Value'range loop - -- Suppress the Ada +ve integer'image leading space - if I > Value'first or else Value (I) /= ' ' then - Str_Table.Append_String8_Char (Value (I)); - else - Length := Length - 1; - end if; - end loop; - Str_Table.Append_String8_Char (' '); - for I in UnitName'range loop - Str_Table.Append_String8_Char (UnitName (I)); - end loop; - - return Build_String (Image_Id, Length, Expr); - end Eval_Physical_Image; - - function Build_Physical_Value (Val: String; Phys_Type, Expr: Iir) return Iir - is - UnitName : String (Val'range); - Mult : Iir_Int64; - Sep : Natural; - Found_Unit : Boolean := false; - Found_Real : Boolean := false; - Unit : Iir; - begin - -- Separate string into numeric value and make lowercase unit. - for I in reverse Val'range loop - UnitName (I) := Ada.Characters.Handling.To_Lower (Val (I)); - if Vhdl.Scanner.Is_Whitespace (Val (I)) and Found_Unit then - Sep := I; - exit; - else - Found_Unit := true; - end if; - end loop; - - -- Unit name is UnitName(Sep+1..Unit'Last) - for I in Val'First .. Sep loop - if Val (I) = '.' then - Found_Real := true; - end if; - end loop; - - -- Chain down the units looking for matching one - Unit := Get_Primary_Unit (Phys_Type); - while Unit /= Null_Iir loop - exit when (UnitName (Sep + 1 .. UnitName'Last) - = Image_Identifier (Unit)); - Unit := Get_Chain (Unit); - end loop; - if Unit = Null_Iir then - Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, - "Unit """ & UnitName (Sep + 1 .. UnitName'Last) - & """ not in physical type"); - return Build_Overflow (Expr); - end if; - - Mult := Get_Value (Get_Physical_Literal (Unit)); - if Found_Real then - return Build_Physical - (Iir_Int64 (Iir_Fp64'Value (Val (Val'First .. Sep)) - * Iir_Fp64 (Mult)), - Expr); - else - return Build_Physical - (Iir_Int64'Value (Val (Val'First .. Sep)) * Mult, Expr); - end if; - end Build_Physical_Value; - - function Eval_Enum_To_String (Lit : Iir; Orig : Iir) return Iir - is - use Str_Table; - Id : constant Name_Id := Get_Identifier (Lit); - Image_Id : constant String8_Id := Str_Table.Create_String8; - Len : Natural; - begin - if Get_Base_Type (Get_Type (Lit)) = Character_Type_Definition then - -- LRM08 5.7 String representations - -- - For a given value of type CHARACTER, the string representation - -- contains one element that is the given value. - Append_String8 (Nat8 (Get_Enum_Pos (Lit))); - Len := 1; - elsif Is_Character (Id) then - -- LRM08 5.7 String representations - -- - For a given value of an enumeration type other than CHARACTER, - -- if the value is a character literal, the string representation - -- contains a single element that is the character literal; [...] - Append_String8_Char (Get_Character (Id)); - Len := 1; - else - -- LRM08 5.7 String representations - -- - [...] otherwise, the string representation is the sequence of - -- characters in the identifier that is the given value. - declare - Img : constant String := Image (Id); - begin - if Img (Img'First) /= '\' then - Append_String8_String (Img); - Len := Img'Length; - else - declare - Skip : Boolean; - C : Character; - begin - Len := 0; - Skip := False; - for I in Img'First + 1 .. Img'Last - 1 loop - if Skip then - Skip := False; - else - C := Img (I); - Append_String8_Char (C); - Skip := C = '\'; - Len := Len + 1; - end if; - end loop; - end; - end if; - end; - end if; - return Build_String (Image_Id, Nat32 (Len), Orig); - end Eval_Enum_To_String; - - function Eval_Incdec (Expr : Iir; N : Iir_Int64; Origin : Iir) return Iir - is - P : Iir_Int64; - begin - case Get_Kind (Expr) is - when Iir_Kind_Integer_Literal => - return Build_Integer (Get_Value (Expr) + N, Origin); - when Iir_Kind_Enumeration_Literal => - P := Iir_Int64 (Get_Enum_Pos (Expr)) + N; - if P < 0 - or else (P >= Iir_Int64 - (Get_Nbr_Elements - (Get_Enumeration_Literal_List - (Get_Base_Type (Get_Type (Expr)))))) - then - Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, - "static constant violates bounds"); - return Build_Overflow (Origin); - else - return Build_Enumeration (Iir_Index32 (P), Origin); - end if; - when Iir_Kind_Physical_Int_Literal - | Iir_Kind_Unit_Declaration => - return Build_Physical (Get_Physical_Value (Expr) + N, Origin); - when others => - Error_Kind ("eval_incdec", Expr); - end case; - end Eval_Incdec; - - function Convert_Range (Rng : Iir; Res_Type : Iir; Loc : Iir) return Iir - is - Res_Btype : Iir; - - function Create_Bound (Val : Iir) return Iir - is - R : Iir; - begin - R := Create_Iir (Iir_Kind_Integer_Literal); - Location_Copy (R, Loc); - Set_Value (R, Get_Value (Val)); - Set_Type (R, Res_Btype); - Set_Expr_Staticness (R, Locally); - return R; - end Create_Bound; - - Res : Iir; - Lit : Iir; - begin - Res_Btype := Get_Base_Type (Res_Type); - Res := Create_Iir (Iir_Kind_Range_Expression); - Location_Copy (Res, Loc); - Set_Type (Res, Res_Btype); - Lit := Create_Bound (Get_Left_Limit (Rng)); - Set_Left_Limit (Res, Lit); - Set_Left_Limit_Expr (Res, Lit); - Lit := Create_Bound (Get_Right_Limit (Rng)); - Set_Right_Limit (Res, Lit); - Set_Right_Limit_Expr (Res, Lit); - Set_Direction (Res, Get_Direction (Rng)); - Set_Expr_Staticness (Res, Locally); - return Res; - end Convert_Range; - - function Eval_Array_Type_Conversion (Conv : Iir; Val : Iir) return Iir - is - Conv_Type : constant Iir := Get_Type (Conv); - Val_Type : constant Iir := Get_Type (Val); - Conv_Index_Type : constant Iir := Get_Index_Type (Conv_Type, 0); - Val_Index_Type : constant Iir := Get_Index_Type (Val_Type, 0); - Index_Type : Iir; - Res_Type : Iir; - Res : Iir; - Rng : Iir; - begin - -- The expression is either a simple aggregate or a (bit) string. - Res := Build_Constant (Val, Conv); - if Get_Constraint_State (Conv_Type) = Fully_Constrained then - Set_Type (Res, Conv_Type); - if not Eval_Is_In_Bound (Val, Conv_Type) then - Warning_Msg_Sem (Warnid_Runtime_Error, +Conv, - "non matching length in type conversion"); - return Build_Overflow (Conv); - end if; - return Res; - else - if Get_Base_Type (Conv_Index_Type) = Get_Base_Type (Val_Index_Type) - then - Index_Type := Val_Index_Type; - else - -- Convert the index range. - -- It is an integer type. - Rng := Convert_Range (Get_Range_Constraint (Val_Index_Type), - Conv_Index_Type, Conv); - Index_Type := Create_Iir (Iir_Kind_Integer_Subtype_Definition); - Location_Copy (Index_Type, Conv); - Set_Range_Constraint (Index_Type, Rng); - Set_Base_Type (Index_Type, Get_Base_Type (Conv_Index_Type)); - Set_Type_Staticness (Index_Type, Locally); - end if; - Res_Type := Create_Unidim_Array_From_Index - (Get_Base_Type (Conv_Type), Index_Type, Conv); - Set_Type (Res, Res_Type); - Set_Type_Conversion_Subtype (Conv, Res_Type); - return Res; - end if; - end Eval_Array_Type_Conversion; - - function Eval_Type_Conversion (Conv : Iir) return Iir - is - Expr : constant Iir := Get_Expression (Conv); - Val : Iir; - Val_Type : Iir; - Conv_Type : Iir; - Res : Iir; - begin - Val := Eval_Static_Expr (Expr); - Val_Type := Get_Base_Type (Get_Type (Val)); - Conv_Type := Get_Base_Type (Get_Type (Conv)); - if Conv_Type = Val_Type then - Res := Build_Constant (Val, Conv); - else - case Get_Kind (Conv_Type) is - when Iir_Kind_Integer_Type_Definition => - case Get_Kind (Val_Type) is - when Iir_Kind_Integer_Type_Definition => - Res := Build_Integer (Get_Value (Val), Conv); - when Iir_Kind_Floating_Type_Definition => - Res := Build_Integer - (Iir_Int64 (Get_Fp_Value (Val)), Conv); - when others => - Error_Kind ("eval_type_conversion(1)", Val_Type); - end case; - when Iir_Kind_Floating_Type_Definition => - case Get_Kind (Val_Type) is - when Iir_Kind_Integer_Type_Definition => - Res := Build_Floating (Iir_Fp64 (Get_Value (Val)), Conv); - when Iir_Kind_Floating_Type_Definition => - Res := Build_Floating (Get_Fp_Value (Val), Conv); - when others => - Error_Kind ("eval_type_conversion(2)", Val_Type); - end case; - when Iir_Kind_Array_Type_Definition => - -- Not a scalar, do not check bounds. - return Eval_Array_Type_Conversion (Conv, Val); - when others => - Error_Kind ("eval_type_conversion(3)", Conv_Type); - end case; - end if; - if not Eval_Is_In_Bound (Res, Get_Type (Conv)) then - if Get_Kind (Res) /= Iir_Kind_Overflow_Literal then - Warning_Msg_Sem (Warnid_Runtime_Error, +Conv, - "result of conversion out of bounds"); - Free_Eval_Static_Expr (Res, Conv); - Res := Build_Overflow (Conv); - end if; - end if; - return Res; - end Eval_Type_Conversion; - - function Eval_Physical_Literal (Expr : Iir) return Iir - is - Val : Iir; - begin - case Get_Kind (Expr) is - when Iir_Kind_Physical_Fp_Literal => - Val := Expr; - when Iir_Kind_Physical_Int_Literal => - -- Create a copy even if the literal has the primary unit. This - -- is required for ownership rule. - Val := Expr; - when Iir_Kind_Unit_Declaration => - Val := Expr; - when Iir_Kinds_Denoting_Name => - Val := Get_Named_Entity (Expr); - pragma Assert (Get_Kind (Val) = Iir_Kind_Unit_Declaration); - when others => - Error_Kind ("eval_physical_literal", Expr); - end case; - return Build_Physical (Get_Physical_Value (Val), Expr); - end Eval_Physical_Literal; - - function Eval_Value_Attribute - (Value : String; Atype : Iir; Orig : Iir) return Iir - is - Base_Type : constant Iir := Get_Base_Type (Atype); - First, Last : Positive; - begin - -- LRM93 14.1 Predefined attributes. - -- Leading and trailing whitespace are ignored. - First := Value'First; - Last := Value'Last; - while First <= Last loop - exit when not Vhdl.Scanner.Is_Whitespace (Value (First)); - First := First + 1; - end loop; - while Last >= First loop - exit when not Vhdl.Scanner.Is_Whitespace (Value (Last)); - Last := Last - 1; - end loop; - - declare - Value1 : String renames Value (First .. Last); - begin - case Get_Kind (Base_Type) is - when Iir_Kind_Integer_Type_Definition => - return Build_Discrete (Iir_Int64'Value (Value1), Orig); - when Iir_Kind_Enumeration_Type_Definition => - return Build_Enumeration_Value (Value1, Base_Type, Orig); - when Iir_Kind_Floating_Type_Definition => - return Build_Floating (Iir_Fp64'value (Value1), Orig); - when Iir_Kind_Physical_Type_Definition => - return Build_Physical_Value (Value1, Base_Type, Orig); - when others => - Error_Kind ("eval_value_attribute", Base_Type); - end case; - end; - end Eval_Value_Attribute; - - -- Be sure that all expressions within an aggregate have been evaluated. - procedure Eval_Aggregate (Aggr : Iir) - is - Assoc : Iir; - Expr : Iir; - begin - Assoc := Get_Association_Choices_Chain (Aggr); - while Is_Valid (Assoc) loop - case Iir_Kinds_Choice (Get_Kind (Assoc)) is - when Iir_Kind_Choice_By_None => - null; - when Iir_Kind_Choice_By_Name => - null; - when Iir_Kind_Choice_By_Range => - Set_Choice_Range - (Assoc, Eval_Range (Get_Choice_Range (Assoc))); - when Iir_Kind_Choice_By_Expression => - Set_Choice_Expression - (Assoc, Eval_Expr (Get_Choice_Expression (Assoc))); - when Iir_Kind_Choice_By_Others => - null; - end case; - if not Get_Same_Alternative_Flag (Assoc) then - Expr := Get_Associated_Expr (Assoc); - end if; - if Get_Kind (Expr) = Iir_Kind_Aggregate then - Eval_Aggregate (Expr); - end if; - Assoc := Get_Chain (Assoc); - end loop; - end Eval_Aggregate; - - function Eval_Selected_Element (Expr : Iir) return Iir - is - Selected_El : constant Iir := Get_Named_Entity (Expr); - El_Pos : constant Iir_Index32 := Get_Element_Position (Selected_El); - Prefix : Iir; - Cur_Pos : Iir_Index32; - Assoc : Iir; - Assoc_Expr : Iir; - Res : Iir; - begin - Prefix := Get_Prefix (Expr); - Prefix := Eval_Static_Expr (Prefix); - if Get_Kind (Prefix) = Iir_Kind_Overflow_Literal then - return Build_Overflow (Expr, Get_Type (Expr)); - end if; - - pragma Assert (Get_Kind (Prefix) = Iir_Kind_Aggregate); - Assoc := Get_Association_Choices_Chain (Prefix); - Cur_Pos := 0; - Assoc_Expr := Null_Iir; - loop - if not Get_Same_Alternative_Flag (Assoc) then - Assoc_Expr := Assoc; - end if; - case Iir_Kinds_Record_Choice (Get_Kind (Assoc)) is - when Iir_Kind_Choice_By_None => - exit when Cur_Pos = El_Pos; - Cur_Pos := Cur_Pos + 1; - when Iir_Kind_Choice_By_Name => - declare - Choice : constant Iir := Get_Choice_Name (Assoc); - begin - exit when Get_Element_Position (Get_Named_Entity (Choice)) - = El_Pos; - end; - when Iir_Kind_Choice_By_Others => - exit; - end case; - Assoc := Get_Chain (Assoc); - end loop; - - -- Eval element and save it. - Res := Eval_Expr_Keep_Orig (Get_Associated_Expr (Assoc_Expr), True); - Set_Associated_Expr (Assoc_Expr, Res); - return Res; - end Eval_Selected_Element; - - function Eval_Indexed_Aggregate (Prefix : Iir; Expr : Iir) return Iir - is - Indexes : constant Iir_Flist := Get_Index_List (Expr); - Prefix_Type : constant Iir := Get_Type (Prefix); - Indexes_Type : constant Iir_Flist := - Get_Index_Subtype_List (Prefix_Type); - Idx : Iir; - Assoc : Iir; - Assoc_Expr : Iir; - Aggr_Bounds : Iir; - Aggr : Iir; - Cur_Pos : Iir_Int64; - Res : Iir; - begin - Aggr := Prefix; - - for Dim in Flist_First .. Flist_Last (Indexes) loop - Idx := Get_Nth_Element (Indexes, Dim); - - -- Find Idx in choices. - Assoc := Get_Association_Choices_Chain (Aggr); - Aggr_Bounds := Eval_Static_Range - (Get_Nth_Element (Indexes_Type, Dim)); - Cur_Pos := Eval_Pos (Eval_Discrete_Range_Left (Aggr_Bounds)); - Assoc_Expr := Null_Iir; - loop - if not Get_Same_Alternative_Flag (Assoc) then - Assoc_Expr := Assoc; - end if; - case Get_Kind (Assoc) is - when Iir_Kind_Choice_By_None => - exit when Cur_Pos = Eval_Pos (Idx); - case Get_Direction (Aggr_Bounds) is - when Iir_To => - Cur_Pos := Cur_Pos + 1; - when Iir_Downto => - Cur_Pos := Cur_Pos - 1; - end case; - when Iir_Kind_Choice_By_Expression => - exit when Eval_Is_Eq (Get_Choice_Expression (Assoc), Idx); - when Iir_Kind_Choice_By_Range => - exit when Eval_Is_In_Bound (Idx, Get_Choice_Range (Assoc)); - when Iir_Kind_Choice_By_Others => - exit; - when others => - raise Internal_Error; - end case; - Assoc := Get_Chain (Assoc); - end loop; - Aggr := Get_Associated_Expr (Assoc_Expr); - end loop; - - -- Eval element and save it. - Res := Eval_Expr_Keep_Orig (Aggr, True); - Set_Associated_Expr (Assoc_Expr, Res); - - return Res; - end Eval_Indexed_Aggregate; - - function Eval_Indexed_String_Literal8 (Str : Iir; Expr : Iir) return Iir - is - Str_Type : constant Iir := Get_Type (Str); - - Index_Type : constant Iir := Get_Index_Type (Str_Type, 0); - Index_Range : constant Iir := Eval_Static_Range (Index_Type); - - Indexes : constant Iir_Flist := Get_Index_List (Expr); - - Id : constant String8_Id := Get_String8_Id (Str); - - Idx : Iir; - Pos : Iir_Index32; - begin - Idx := Eval_Static_Expr (Get_Nth_Element (Indexes, 0)); - Pos := Eval_Pos_In_Range (Index_Range, Idx); - - return Build_Enumeration_Constant - (Iir_Index32 (Str_Table.Element_String8 (Id, Int32 (Pos + 1))), Expr); - end Eval_Indexed_String_Literal8; - - function Eval_Indexed_Simple_Aggregate (Aggr : Iir; Expr : Iir) return Iir - is - Aggr_Type : constant Iir := Get_Type (Aggr); - - Index_Type : constant Iir := Get_Index_Type (Aggr_Type, 0); - Index_Range : constant Iir := Eval_Static_Range (Index_Type); - - Indexes : constant Iir_Flist := Get_Index_List (Expr); - - Idx : Iir; - Pos : Iir_Index32; - El : Iir; - begin - Idx := Eval_Static_Expr (Get_Nth_Element (Indexes, 0)); - Set_Nth_Element (Indexes, 0, Idx); - Pos := Eval_Pos_In_Range (Index_Range, Idx); - - El := Get_Nth_Element (Get_Simple_Aggregate_List (Aggr), Natural (Pos)); - return Build_Constant (El, Expr); - end Eval_Indexed_Simple_Aggregate; - - function Eval_Indexed_Name (Expr : Iir) return Iir - is - Prefix : Iir; - begin - Prefix := Get_Prefix (Expr); - Prefix := Eval_Static_Expr (Prefix); - - declare - Prefix_Type : constant Iir := Get_Type (Prefix); - Indexes_Type : constant Iir_Flist := - Get_Index_Subtype_List (Prefix_Type); - Indexes_List : constant Iir_Flist := Get_Index_List (Expr); - Prefix_Index : Iir; - Index : Iir; - begin - for I in Flist_First .. Flist_Last (Indexes_Type) loop - Prefix_Index := Get_Nth_Element (Indexes_Type, I); - - -- Eval index. - Index := Get_Nth_Element (Indexes_List, I); - Index := Eval_Static_Expr (Index); - Set_Nth_Element (Indexes_List, I, Index); - - -- Return overflow if out of range. - if Get_Kind (Index) = Iir_Kind_Overflow_Literal - or else not Eval_Is_In_Bound (Index, Prefix_Index) - then - return Build_Overflow (Expr, Get_Type (Expr)); - end if; - end loop; - end; - - case Get_Kind (Prefix) is - when Iir_Kind_Aggregate => - return Eval_Indexed_Aggregate (Prefix, Expr); - when Iir_Kind_String_Literal8 => - return Eval_Indexed_String_Literal8 (Prefix, Expr); - when Iir_Kind_Simple_Aggregate => - return Eval_Indexed_Simple_Aggregate (Prefix, Expr); - when Iir_Kind_Overflow_Literal => - return Build_Overflow (Expr, Get_Type (Expr)); - when others => - Error_Kind ("eval_indexed_name", Prefix); - end case; - end Eval_Indexed_Name; - - function Eval_Indexed_Aggregate_By_Offset - (Aggr : Iir; Off : Iir_Index32; Dim : Natural := 0) return Iir - is - Prefix_Type : constant Iir := Get_Type (Aggr); - Indexes_Type : constant Iir_Flist := - Get_Index_Subtype_List (Prefix_Type); - Assoc : Iir; - Assoc_Expr : Iir; - Assoc_Len : Iir_Index32; - Aggr_Bounds : Iir; - Cur_Off : Iir_Index32; - Res : Iir; - Left_Pos : Iir_Int64; - Assoc_Pos : Iir_Int64; - begin - Aggr_Bounds := Eval_Static_Range (Get_Nth_Element (Indexes_Type, Dim)); - Left_Pos := Eval_Pos (Eval_Discrete_Range_Left (Aggr_Bounds)); - - Cur_Off := 0; - Assoc := Get_Association_Choices_Chain (Aggr); - Assoc_Expr := Null_Iir; - while Assoc /= Null_Iir loop - if not Get_Same_Alternative_Flag (Assoc) then - Assoc_Expr := Assoc; - end if; - case Get_Kind (Assoc) is - when Iir_Kind_Choice_By_None => - if Get_Element_Type_Flag (Assoc) then - if Off = Cur_Off then - return Get_Associated_Expr (Assoc); - end if; - Assoc_Len := 1; - else - Res := Get_Associated_Expr (Assoc); - Assoc_Len := Iir_Index32 - (Eval_Discrete_Range_Length - (Get_Index_Type (Get_Type (Res), 0))); - if Off >= Cur_Off and then Off < Cur_Off + Assoc_Len then - return Eval_Indexed_Name_By_Offset (Res, Off - Cur_Off); - end if; - end if; - Cur_Off := Cur_Off + Assoc_Len; - when Iir_Kind_Choice_By_Expression => - Assoc_Pos := Eval_Pos (Get_Choice_Expression (Assoc)); - case Get_Direction (Aggr_Bounds) is - when Iir_To => - Cur_Off := Iir_Index32 (Assoc_Pos - Left_Pos); - when Iir_Downto => - Cur_Off := Iir_Index32 (Left_Pos - Assoc_Pos); - end case; - if Cur_Off = Off then - return Get_Associated_Expr (Assoc); - end if; - when Iir_Kind_Choice_By_Range => - declare - Rng : Iir; - Left : Iir_Int64; - Right : Iir_Int64; - Hi, Lo : Iir_Int64; - Lo_Off, Hi_Off : Iir_Index32; - begin - Rng := Eval_Range (Get_Choice_Range (Assoc)); - Set_Choice_Range (Assoc, Rng); - - Left := Eval_Pos (Get_Left_Limit (Rng)); - Right := Eval_Pos (Get_Right_Limit (Rng)); - case Get_Direction (Rng) is - when Iir_To => - Lo := Left; - Hi := Right; - when Iir_Downto => - Lo := Right; - Hi := Left; - end case; - case Get_Direction (Aggr_Bounds) is - when Iir_To => - Lo_Off := Iir_Index32 (Lo - Left_Pos); - Hi_Off := Iir_Index32 (Hi - Left_Pos); - when Iir_Downto => - Lo_Off := Iir_Index32 (Left_Pos - Lo); - Hi_Off := Iir_Index32 (Left_Pos - Hi); - end case; - if Off >= Lo_Off and then Off <= Hi_Off then - Res := Get_Associated_Expr (Assoc); - if Get_Element_Type_Flag (Assoc) then - return Res; - else - return Eval_Indexed_Name_By_Offset - (Res, Off - Lo_Off); - end if; - end if; - end; - when Iir_Kind_Choice_By_Others => - return Get_Associated_Expr (Assoc_Expr); - when others => - raise Internal_Error; - end case; - Assoc := Get_Chain (Assoc); - end loop; - raise Internal_Error; - end Eval_Indexed_Aggregate_By_Offset; - - function Eval_Indexed_Name_By_Offset (Prefix : Iir; Off : Iir_Index32) - return Iir - is - begin - case Get_Kind (Prefix) is - when Iir_Kind_Aggregate => - return Eval_Indexed_Aggregate_By_Offset (Prefix, Off); - when Iir_Kind_String_Literal8 => - declare - Id : constant String8_Id := Get_String8_Id (Prefix); - El_Type : constant Iir := - Get_Element_Subtype (Get_Type (Prefix)); - Enums : constant Iir_Flist := - Get_Enumeration_Literal_List (El_Type); - Lit : Pos32; - begin - Lit := Str_Table.Element_String8 (Id, Int32 (Off + 1)); - return Get_Nth_Element (Enums, Natural (Lit)); - end; - when Iir_Kind_Simple_Aggregate => - return Get_Nth_Element (Get_Simple_Aggregate_List (Prefix), - Natural (Off)); - when others => - Error_Kind ("eval_indexed_name_by_offset", Prefix); - end case; - end Eval_Indexed_Name_By_Offset; - - function Eval_Static_Expr (Expr: Iir) return Iir - is - Res : Iir; - Val : Iir; - begin - case Get_Kind (Expr) is - when Iir_Kinds_Denoting_Name => - return Eval_Static_Expr (Get_Named_Entity (Expr)); - - when Iir_Kind_Integer_Literal - | Iir_Kind_Enumeration_Literal - | Iir_Kind_Floating_Point_Literal - | Iir_Kind_String_Literal8 - | Iir_Kind_Overflow_Literal - | Iir_Kind_Physical_Int_Literal - | Iir_Kind_Physical_Fp_Literal => - return Expr; - when Iir_Kind_Constant_Declaration => - Val := Eval_Static_Expr (Get_Default_Value (Expr)); - -- Type of the expression should be type of the constant - -- declaration at least in case of array subtype. - -- If the constant is declared as an unconstrained array, get type - -- from the default value. - -- FIXME: handle this during semantisation of the declaration: - -- add an implicit subtype conversion node ? - -- FIXME: this currently creates a node at each evalation. - if Get_Kind (Get_Type (Val)) = Iir_Kind_Array_Type_Definition then - Res := Build_Constant (Val, Expr); - Set_Type (Res, Get_Type (Val)); - return Res; - else - return Val; - end if; - when Iir_Kind_Object_Alias_Declaration => - return Eval_Static_Expr (Get_Name (Expr)); - when Iir_Kind_Unit_Declaration => - return Get_Physical_Literal (Expr); - when Iir_Kind_Simple_Aggregate => - return Expr; - when Iir_Kind_Aggregate => - Eval_Aggregate (Expr); - return Expr; - - when Iir_Kind_Selected_Element => - return Eval_Selected_Element (Expr); - when Iir_Kind_Indexed_Name => - return Eval_Indexed_Name (Expr); - - when Iir_Kind_Parenthesis_Expression => - return Eval_Static_Expr (Get_Expression (Expr)); - when Iir_Kind_Qualified_Expression => - return Eval_Static_Expr (Get_Expression (Expr)); - when Iir_Kind_Type_Conversion => - return Eval_Type_Conversion (Expr); - - when Iir_Kinds_Monadic_Operator => - declare - Operand : Iir; - begin - Operand := Eval_Static_Expr (Get_Operand (Expr)); - return Eval_Monadic_Operator (Expr, Operand); - end; - when Iir_Kinds_Dyadic_Operator => - declare - Left : constant Iir := Get_Left (Expr); - Right : constant Iir := Get_Right (Expr); - Left_Val, Right_Val : Iir; - Res : Iir; - begin - Left_Val := Eval_Static_Expr (Left); - Right_Val := Eval_Static_Expr (Right); - - Res := Eval_Dyadic_Operator - (Expr, Get_Implementation (Expr), Left_Val, Right_Val); - - Free_Eval_Static_Expr (Left_Val, Left); - Free_Eval_Static_Expr (Right_Val, Right); - - return Res; - end; - - when Iir_Kind_Attribute_Name => - -- An attribute name designates an attribute value. - declare - Attr_Expr : constant Iir := - Get_Attribute_Name_Expression (Expr); - Val : Iir; - begin - Val := Eval_Static_Expr (Attr_Expr); - -- FIXME: see constant_declaration. - -- Currently, this avoids weird nodes, such as a string literal - -- whose type is an unconstrained array type. - Res := Build_Constant (Val, Expr); - Set_Type (Res, Get_Type (Val)); - return Res; - end; - - when Iir_Kind_Pos_Attribute => - declare - Param : constant Iir := Get_Parameter (Expr); - Val : Iir; - Res : Iir; - begin - Val := Eval_Static_Expr (Param); - -- FIXME: check bounds, handle overflow. - Res := Build_Integer (Eval_Pos (Val), Expr); - Free_Eval_Static_Expr (Val, Param); - return Res; - end; - when Iir_Kind_Val_Attribute => - declare - Expr_Type : constant Iir := Get_Type (Expr); - Val_Expr : Iir; - Val : Iir_Int64; - begin - Val_Expr := Eval_Static_Expr (Get_Parameter (Expr)); - Val := Eval_Pos (Val_Expr); - -- Note: the type of 'val is a base type. - -- FIXME: handle VHDL93 restrictions. - if Get_Kind (Expr_Type) = Iir_Kind_Enumeration_Type_Definition - and then - not Eval_Int_In_Range (Val, Get_Range_Constraint (Expr_Type)) - then - Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, - "static argument out of the type range"); - return Build_Overflow (Expr); - end if; - if Get_Kind (Get_Base_Type (Get_Type (Expr))) - = Iir_Kind_Physical_Type_Definition - then - return Build_Physical (Val, Expr); - else - return Build_Discrete (Val, Expr); - end if; - end; - when Iir_Kind_Image_Attribute => - declare - Param : Iir; - Param_Type : Iir; - begin - Param := Get_Parameter (Expr); - Param := Eval_Static_Expr (Param); - Eval_Check_Bound (Param, Get_Type (Get_Prefix (Expr))); - Set_Parameter (Expr, Param); - - -- Special case for overflow. - if Get_Kind (Param) = Iir_Kind_Overflow_Literal then - return Build_Overflow (Expr); - end if; - - Param_Type := Get_Base_Type (Get_Type (Param)); - case Get_Kind (Param_Type) is - when Iir_Kind_Integer_Type_Definition => - return Eval_Integer_Image (Get_Value (Param), Expr); - when Iir_Kind_Floating_Type_Definition => - return Eval_Floating_Image (Get_Fp_Value (Param), Expr); - when Iir_Kind_Enumeration_Type_Definition => - return Eval_Enumeration_Image (Param, Expr); - when Iir_Kind_Physical_Type_Definition => - return Eval_Physical_Image (Param, Expr); - when others => - Error_Kind ("eval_static_expr('image)", Param); - end case; - end; - when Iir_Kind_Value_Attribute => - declare - Param : Iir; - begin - Param := Get_Parameter (Expr); - Param := Eval_Static_Expr (Param); - Set_Parameter (Expr, Param); - if Get_Kind (Param) /= Iir_Kind_String_Literal8 then - -- FIXME: Isn't it an implementation restriction. - Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, - "'value argument not a string"); - return Build_Overflow (Expr); - else - return Eval_Value_Attribute - (Image_String_Lit (Param), Get_Type (Expr), Expr); - end if; - end; - - when Iir_Kind_Left_Type_Attribute => - return Eval_Static_Expr - (Get_Left_Limit (Eval_Static_Range (Get_Prefix (Expr)))); - when Iir_Kind_Right_Type_Attribute => - return Eval_Static_Expr - (Get_Right_Limit (Eval_Static_Range (Get_Prefix (Expr)))); - when Iir_Kind_High_Type_Attribute => - return Eval_Static_Expr - (Get_High_Limit (Eval_Static_Range (Get_Prefix (Expr)))); - when Iir_Kind_Low_Type_Attribute => - return Eval_Static_Expr - (Get_Low_Limit (Eval_Static_Range (Get_Prefix (Expr)))); - when Iir_Kind_Ascending_Type_Attribute => - return Build_Boolean - (Get_Direction (Eval_Static_Range (Get_Prefix (Expr))) = Iir_To); - - when Iir_Kind_Length_Array_Attribute => - declare - Index : Iir; - begin - Index := Eval_Array_Attribute (Expr); - return Build_Discrete (Eval_Discrete_Type_Length (Index), Expr); - end; - when Iir_Kind_Left_Array_Attribute => - declare - Index : Iir; - begin - Index := Eval_Array_Attribute (Expr); - return Eval_Static_Expr - (Get_Left_Limit (Get_Range_Constraint (Index))); - end; - when Iir_Kind_Right_Array_Attribute => - declare - Index : Iir; - begin - Index := Eval_Array_Attribute (Expr); - return Eval_Static_Expr - (Get_Right_Limit (Get_Range_Constraint (Index))); - end; - when Iir_Kind_Low_Array_Attribute => - declare - Index : Iir; - begin - Index := Eval_Array_Attribute (Expr); - return Eval_Static_Expr - (Get_Low_Limit (Get_Range_Constraint (Index))); - end; - when Iir_Kind_High_Array_Attribute => - declare - Index : Iir; - begin - Index := Eval_Array_Attribute (Expr); - return Eval_Static_Expr - (Get_High_Limit (Get_Range_Constraint (Index))); - end; - when Iir_Kind_Ascending_Array_Attribute => - declare - Index : Iir; - begin - Index := Eval_Array_Attribute (Expr); - return Build_Boolean - (Get_Direction (Get_Range_Constraint (Index)) = Iir_To); - end; - - when Iir_Kind_Pred_Attribute => - Res := Eval_Incdec - (Eval_Static_Expr (Get_Parameter (Expr)), -1, Expr); - Eval_Check_Bound (Res, Get_Type (Get_Prefix (Expr))); - return Res; - when Iir_Kind_Succ_Attribute => - Res := Eval_Incdec - (Eval_Static_Expr (Get_Parameter (Expr)), +1, Expr); - Eval_Check_Bound (Res, Get_Type (Get_Prefix (Expr))); - return Res; - when Iir_Kind_Leftof_Attribute - | Iir_Kind_Rightof_Attribute => - declare - Rng : Iir; - N : Iir_Int64; - Prefix_Type : constant Iir := Get_Type (Get_Prefix (Expr)); - Res : Iir; - begin - Rng := Eval_Static_Range (Prefix_Type); - case Get_Direction (Rng) is - when Iir_To => - N := 1; - when Iir_Downto => - N := -1; - end case; - case Get_Kind (Expr) is - when Iir_Kind_Leftof_Attribute => - N := -N; - when Iir_Kind_Rightof_Attribute => - null; - when others => - raise Internal_Error; - end case; - Res := Eval_Incdec - (Eval_Static_Expr (Get_Parameter (Expr)), N, Expr); - Eval_Check_Bound (Res, Prefix_Type); - return Res; - end; - - when Iir_Kind_Simple_Name_Attribute => - declare - use Str_Table; - Img : constant String := - Image (Get_Simple_Name_Identifier (Expr)); - Id : String8_Id; - begin - Id := Create_String8; - for I in Img'Range loop - Append_String8_Char (Img (I)); - end loop; - return Build_String (Id, Nat32 (Img'Length), Expr); - end; - - when Iir_Kind_Null_Literal => - return Expr; - - when Iir_Kind_Function_Call => - declare - Imp : constant Iir := Get_Implementation (Expr); - Left, Right : Iir; - begin - -- Note: there can't be association by name. - Left := Get_Parameter_Association_Chain (Expr); - Right := Get_Chain (Left); - - Left := Eval_Static_Expr (Get_Actual (Left)); - if Right = Null_Iir then - return Eval_Monadic_Operator (Expr, Left); - else - Right := Eval_Static_Expr (Get_Actual (Right)); - return Eval_Dyadic_Operator (Expr, Imp, Left, Right); - end if; - end; - - when Iir_Kind_Error => - return Expr; - when others => - Error_Kind ("eval_static_expr", Expr); - end case; - end Eval_Static_Expr; - - -- If FORCE is true, always return a literal. - function Eval_Expr_Keep_Orig (Expr : Iir; Force : Boolean) return Iir - is - Res : Iir; - begin - case Get_Kind (Expr) is - when Iir_Kinds_Denoting_Name => - declare - Orig : constant Iir := Get_Named_Entity (Expr); - begin - Res := Eval_Static_Expr (Orig); - if Res /= Orig or else Force then - return Build_Constant (Res, Expr); - else - return Expr; - end if; - end; - when others => - Res := Eval_Static_Expr (Expr); - if Res /= Expr - and then Get_Literal_Origin (Res) /= Expr - then - -- Need to build a constant if the result is a different - -- literal not tied to EXPR. - return Build_Constant (Res, Expr); - else - return Res; - end if; - end case; - end Eval_Expr_Keep_Orig; - - function Eval_Expr (Expr: Iir) return Iir is - begin - if Get_Expr_Staticness (Expr) /= Locally then - Error_Msg_Sem (+Expr, "expression must be locally static"); - return Expr; - else - return Eval_Expr_Keep_Orig (Expr, False); - end if; - end Eval_Expr; - - -- Subroutine of Can_Eval_Composite_Value. Return True iff EXPR is - -- considered as a small composite. - function Is_Small_Composite_Value (Expr : Iir) return Boolean - is - Expr_Type : constant Iir := Get_Type (Expr); - Indexes : Iir_Flist; - Len : Iir_Int64; - begin - -- Consider only arrays. Records are never composite. - if Get_Kind (Expr_Type) /= Iir_Kind_Array_Subtype_Definition then - return False; - end if; - - -- Element must be scalar. - if Get_Kind (Get_Element_Subtype (Expr_Type)) - not in Iir_Kinds_Scalar_Type_And_Subtype_Definition - then - return False; - end if; - - Indexes := Get_Index_Subtype_List (Expr_Type); - - -- Multi-dimensional arrays aren't considered as small. - if Get_Nbr_Elements (Indexes) /= 1 then - return False; - end if; - - Len := Eval_Discrete_Type_Length (Get_Nth_Element (Indexes, 0)); - return Len <= 128; - end Is_Small_Composite_Value; - - function Can_Eval_Composite_Value (Expr : Iir; Top : Boolean := False) - return Boolean; - - -- Return True if EXPR should be evaluated. - function Can_Eval_Value (Expr : Iir; Top : Boolean) return Boolean is - begin - -- Always evaluate scalar values. - if Get_Kind (Get_Type (Expr)) - in Iir_Kinds_Scalar_Type_And_Subtype_Definition - then - return True; - end if; - return Can_Eval_Composite_Value (Expr, Top); - end Can_Eval_Value; - - -- For composite values. - -- Evluating a composite value is a trade-off: it can simplify the - -- generated code if the value is small enough, or it can be a bad idea if - -- the value is very large. It is very easy to create large static - -- composite values (like: bit_vector'(1 to 10**4 => '0')) - function Can_Eval_Composite_Value (Expr : Iir; Top : Boolean := False) - return Boolean - is - -- We are only considering static values. - pragma Assert (Get_Expr_Staticness (Expr) = Locally); - - -- We are only considering composite types. - pragma Assert (Get_Kind (Get_Type (Expr)) - not in Iir_Kinds_Scalar_Type_And_Subtype_Definition); - begin - case Get_Kind (Expr) is - when Iir_Kind_Type_Conversion - | Iir_Kind_Qualified_Expression => - -- Not yet handled. - return False; - when Iir_Kinds_Denoting_Name => - return Can_Eval_Composite_Value (Get_Named_Entity (Expr), Top); - when Iir_Kind_Constant_Declaration => - -- Pass through names only for small values. - if Top or else not Is_Small_Composite_Value (Expr) then - return False; - else - return Can_Eval_Composite_Value (Get_Default_Value (Expr)); - end if; - when Iir_Kind_Attribute_Name => - if Top or else not Is_Small_Composite_Value (Expr) then - return False; - else - return Can_Eval_Composite_Value - (Get_Attribute_Name_Expression (Expr)); - end if; - when Iir_Kinds_Dyadic_Operator => - -- Concatenation can increase the size. - -- Others (rol, ror...) don't. - return Can_Eval_Value (Get_Left (Expr), False) - and then Can_Eval_Value (Get_Right (Expr), False); - when Iir_Kinds_Monadic_Operator => - -- For not. - return Can_Eval_Composite_Value (Get_Operand (Expr)); - when Iir_Kind_Aggregate => - return Is_Small_Composite_Value (Expr); - when Iir_Kinds_Literal - | Iir_Kind_Enumeration_Literal - | Iir_Kind_Simple_Aggregate - | Iir_Kind_Image_Attribute - | Iir_Kind_Simple_Name_Attribute => - return True; - when Iir_Kind_Overflow_Literal => - return True; - when Iir_Kind_Function_Call => - -- Either using post-fixed notation or implicit functions like - -- to_string. - -- Cannot be a user function (won't be locally static). - declare - Assoc : Iir; - Assoc_Expr : Iir; - begin - Assoc := Get_Parameter_Association_Chain (Expr); - while Is_Valid (Assoc) loop - case Iir_Kinds_Association_Element (Get_Kind (Assoc)) is - when Iir_Kind_Association_Element_By_Expression => - Assoc_Expr := Get_Actual (Assoc); - if not Can_Eval_Value (Assoc_Expr, False) then - return False; - end if; - when Iir_Kind_Association_Element_Open => - null; - when Iir_Kind_Association_Element_By_Individual => - return False; - end case; - Assoc := Get_Chain (Assoc); - end loop; - return True; - end; - - when others => - -- Be safe, don't crash on unhandled expression. - -- Error_Kind ("can_eval_composite_value", Expr); - return False; - end case; - end Can_Eval_Composite_Value; - - function Eval_Expr_If_Static (Expr : Iir) return Iir is - begin - if Expr /= Null_Iir and then Get_Expr_Staticness (Expr) = Locally then - -- Evaluate only when there is a positive effect. - if Can_Eval_Value (Expr, True) then - return Eval_Expr_Keep_Orig (Expr, False); - else - return Expr; - end if; - else - return Expr; - end if; - end Eval_Expr_If_Static; - - function Eval_Expr_Check (Expr : Iir; Sub_Type : Iir) return Iir - is - Res : Iir; - begin - Res := Eval_Expr_Keep_Orig (Expr, False); - Eval_Check_Bound (Res, Sub_Type); - return Res; - end Eval_Expr_Check; - - function Eval_Expr_Check_If_Static (Expr : Iir; Atype : Iir) return Iir - is - Res : Iir; - begin - if Expr /= Null_Iir and then Get_Expr_Staticness (Expr) = Locally then - -- Expression is static and can be evaluated. Don't try to - -- evaluate non-scalar expressions, that may create too large data. - if Get_Kind (Atype) in Iir_Kinds_Scalar_Type_And_Subtype_Definition - then - Res := Eval_Expr_Keep_Orig (Expr, False); - else - Res := Expr; - end if; - - if Res /= Null_Iir - and then Get_Type_Staticness (Atype) = Locally - and then Get_Kind (Atype) in Iir_Kinds_Range_Type_Definition - then - -- Check bounds (as this can be done). - -- FIXME: create overflow_expr ? - Eval_Check_Bound (Res, Atype); - end if; - - return Res; - else - return Expr; - end if; - end Eval_Expr_Check_If_Static; - - function Eval_Int_In_Range (Val : Iir_Int64; Bound : Iir) return Boolean is - begin - case Get_Kind (Bound) is - when Iir_Kind_Range_Expression => - case Get_Direction (Bound) is - when Iir_To => - if Val < Eval_Pos (Get_Left_Limit (Bound)) - or else Val > Eval_Pos (Get_Right_Limit (Bound)) - then - return False; - end if; - when Iir_Downto => - if Val > Eval_Pos (Get_Left_Limit (Bound)) - or else Val < Eval_Pos (Get_Right_Limit (Bound)) - then - return False; - end if; - end case; - when others => - Error_Kind ("eval_int_in_range", Bound); - end case; - return True; - end Eval_Int_In_Range; - - function Eval_Phys_In_Range (Val : Iir_Int64; Bound : Iir) return Boolean - is - Left, Right : Iir_Int64; - begin - case Get_Kind (Bound) is - when Iir_Kind_Range_Expression => - case Get_Kind (Get_Type (Get_Left_Limit (Bound))) is - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Integer_Subtype_Definition => - Left := Get_Value (Get_Left_Limit (Bound)); - Right := Get_Value (Get_Right_Limit (Bound)); - when Iir_Kind_Physical_Type_Definition - | Iir_Kind_Physical_Subtype_Definition => - Left := Get_Physical_Value (Get_Left_Limit (Bound)); - Right := Get_Physical_Value (Get_Right_Limit (Bound)); - when others => - Error_Kind ("eval_phys_in_range(1)", Get_Type (Bound)); - end case; - case Get_Direction (Bound) is - when Iir_To => - if Val < Left or else Val > Right then - return False; - end if; - when Iir_Downto => - if Val > Left or else Val < Right then - return False; - end if; - end case; - when others => - Error_Kind ("eval_phys_in_range", Bound); - end case; - return True; - end Eval_Phys_In_Range; - - function Eval_Fp_In_Range (Val : Iir_Fp64; Bound : Iir) return Boolean is - begin - case Get_Kind (Bound) is - when Iir_Kind_Range_Expression => - case Get_Direction (Bound) is - when Iir_To => - if Val < Get_Fp_Value (Get_Left_Limit (Bound)) - or else Val > Get_Fp_Value (Get_Right_Limit (Bound)) - then - return False; - end if; - when Iir_Downto => - if Val > Get_Fp_Value (Get_Left_Limit (Bound)) - or else Val < Get_Fp_Value (Get_Right_Limit (Bound)) - then - return False; - end if; - end case; - when others => - Error_Kind ("eval_fp_in_range", Bound); - end case; - return True; - end Eval_Fp_In_Range; - - -- Return FALSE if literal EXPR is not in SUB_TYPE bounds. - function Eval_Is_In_Bound (Expr : Iir; Sub_Type : Iir) return Boolean - is - Type_Range : Iir; - Val : Iir; - begin - case Get_Kind (Expr) is - when Iir_Kind_Simple_Name - | Iir_Kind_Character_Literal - | Iir_Kind_Selected_Name - | Iir_Kind_Parenthesis_Name => - Val := Get_Named_Entity (Expr); - when others => - Val := Expr; - end case; - - case Get_Kind (Val) is - when Iir_Kind_Error => - -- Ignore errors. - return True; - when Iir_Kind_Overflow_Literal => - -- Never within bounds - return False; - when others => - null; - end case; - - case Get_Kind (Sub_Type) is - when Iir_Kind_Integer_Subtype_Definition => - if Get_Expr_Staticness (Val) /= Locally - or else Get_Type_Staticness (Sub_Type) /= Locally - then - return True; - end if; - Type_Range := Get_Range_Constraint (Sub_Type); - return Eval_Int_In_Range (Get_Value (Val), Type_Range); - - when Iir_Kind_Floating_Subtype_Definition => - if Get_Expr_Staticness (Val) /= Locally - or else Get_Type_Staticness (Sub_Type) /= Locally - then - return True; - end if; - Type_Range := Get_Range_Constraint (Sub_Type); - return Eval_Fp_In_Range (Get_Fp_Value (Val), Type_Range); - - when Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Enumeration_Type_Definition => - if Get_Expr_Staticness (Val) /= Locally - or else Get_Type_Staticness (Sub_Type) /= Locally - then - return True; - end if; - -- A check is required for an enumeration type definition for - -- 'val attribute. - Type_Range := Get_Range_Constraint (Sub_Type); - return Eval_Int_In_Range - (Iir_Int64 (Get_Enum_Pos (Val)), Type_Range); - - when Iir_Kind_Physical_Subtype_Definition => - if Get_Expr_Staticness (Val) /= Locally - or else Get_Type_Staticness (Sub_Type) /= Locally - then - return True; - end if; - Type_Range := Get_Range_Constraint (Sub_Type); - return Eval_Phys_In_Range (Get_Physical_Value (Val), Type_Range); - - when Iir_Kind_Base_Attribute => - if Get_Expr_Staticness (Val) /= Locally - or else Get_Type_Staticness (Sub_Type) /= Locally - then - return True; - end if; - return Eval_Is_In_Bound (Val, Get_Type (Sub_Type)); - - when Iir_Kind_Array_Subtype_Definition => - declare - Val_Type : constant Iir := Get_Type (Val); - begin - if Is_Null (Val_Type) then - -- Punt on errors. - return True; - end if; - - if Get_Constraint_State (Sub_Type) /= Fully_Constrained - or else - Get_Kind (Val_Type) /= Iir_Kind_Array_Subtype_Definition - or else - Get_Constraint_State (Val_Type) /= Fully_Constrained - then - -- Cannot say no. - return True; - end if; - declare - E_Indexes : constant Iir_Flist := - Get_Index_Subtype_List (Val_Type); - T_Indexes : constant Iir_Flist := - Get_Index_Subtype_List (Sub_Type); - E_El : Iir; - T_El : Iir; - begin - for I in Flist_First .. Flist_Last (E_Indexes) loop - E_El := Get_Index_Type (E_Indexes, I); - T_El := Get_Index_Type (T_Indexes, I); - - if Get_Type_Staticness (E_El) = Locally - and then Get_Type_Staticness (T_El) = Locally - and then (Eval_Discrete_Type_Length (E_El) - /= Eval_Discrete_Type_Length (T_El)) - then - return False; - end if; - end loop; - return True; - end; - end; - - when Iir_Kind_Access_Type_Definition - | Iir_Kind_Access_Subtype_Definition => - return True; - - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - -- FIXME: do it. - return True; - - when Iir_Kind_File_Type_Definition => - return True; - - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Physical_Type_Definition - | Iir_Kind_Floating_Type_Definition => - return True; - - when Iir_Kind_Interface_Type_Definition - | Iir_Kind_Protected_Type_Declaration => - return True; - - when Iir_Kind_Error => - return True; - - when others => - Error_Kind ("eval_is_in_bound", Sub_Type); - end case; - end Eval_Is_In_Bound; - - procedure Eval_Check_Bound (Expr : Iir; Sub_Type : Iir) is - begin - if Get_Kind (Expr) = Iir_Kind_Overflow_Literal then - -- Nothing to check, and a message was already generated. - return; - end if; - - if not Eval_Is_In_Bound (Expr, Sub_Type) then - Error_Msg_Sem (+Expr, "static expression violates bounds"); - end if; - end Eval_Check_Bound; - - function Eval_Is_Range_In_Bound - (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean) - return Boolean - is - Type_Range : Iir; - Range_Constraint : constant Iir := Eval_Static_Range (A_Range); - begin - Type_Range := Get_Range_Constraint (Sub_Type); - if not Any_Dir - and then Get_Direction (Type_Range) /= Get_Direction (Range_Constraint) - then - return True; - end if; - - case Get_Kind (Sub_Type) is - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Enumeration_Type_Definition => - declare - L, R : Iir_Int64; - begin - -- Check for null range. - L := Eval_Pos (Get_Left_Limit (Range_Constraint)); - R := Eval_Pos (Get_Right_Limit (Range_Constraint)); - case Get_Direction (Range_Constraint) is - when Iir_To => - if L > R then - return True; - end if; - when Iir_Downto => - if L < R then - return True; - end if; - end case; - return Eval_Int_In_Range (L, Type_Range) - and then Eval_Int_In_Range (R, Type_Range); - end; - when Iir_Kind_Floating_Subtype_Definition => - declare - L, R : Iir_Fp64; - begin - -- Check for null range. - L := Get_Fp_Value (Get_Left_Limit (Range_Constraint)); - R := Get_Fp_Value (Get_Right_Limit (Range_Constraint)); - case Get_Direction (Range_Constraint) is - when Iir_To => - if L > R then - return True; - end if; - when Iir_Downto => - if L < R then - return True; - end if; - end case; - return Eval_Fp_In_Range (L, Type_Range) - and then Eval_Fp_In_Range (R, Type_Range); - end; - when others => - Error_Kind ("eval_is_range_in_bound", Sub_Type); - end case; - - -- Should check L <= R or L >= R according to direction. - --return Eval_Is_In_Bound (Get_Left_Limit (A_Range), Sub_Type) - -- and then Eval_Is_In_Bound (Get_Right_Limit (A_Range), Sub_Type); - end Eval_Is_Range_In_Bound; - - procedure Eval_Check_Range - (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean) - is - begin - if not Eval_Is_Range_In_Bound (A_Range, Sub_Type, Any_Dir) then - Error_Msg_Sem (+A_Range, "static range violates bounds"); - end if; - end Eval_Check_Range; - - function Eval_Discrete_Range_Length (Constraint : Iir) return Iir_Int64 - is - -- We don't want to deal with very large ranges here. - pragma Suppress (Overflow_Check); - Res : Iir_Int64; - Left, Right : Iir_Int64; - begin - Left := Eval_Pos (Get_Left_Limit (Constraint)); - Right := Eval_Pos (Get_Right_Limit (Constraint)); - case Get_Direction (Constraint) is - when Iir_To => - if Right < Left then - -- Null range. - return 0; - else - Res := Right - Left + 1; - end if; - when Iir_Downto => - if Left < Right then - -- Null range - return 0; - else - Res := Left - Right + 1; - end if; - end case; - return Res; - end Eval_Discrete_Range_Length; - - function Eval_Discrete_Type_Length (Sub_Type : Iir) return Iir_Int64 - is - begin - case Get_Kind (Sub_Type) is - when Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Integer_Subtype_Definition => - return Eval_Discrete_Range_Length - (Get_Range_Constraint (Sub_Type)); - when others => - Error_Kind ("eval_discrete_type_length", Sub_Type); - end case; - end Eval_Discrete_Type_Length; - - function Eval_Pos (Expr : Iir) return Iir_Int64 is - begin - case Get_Kind (Expr) is - when Iir_Kind_Integer_Literal => - return Get_Value (Expr); - when Iir_Kind_Enumeration_Literal => - return Iir_Int64 (Get_Enum_Pos (Expr)); - when Iir_Kind_Physical_Int_Literal - | Iir_Kind_Physical_Fp_Literal - | Iir_Kind_Unit_Declaration => - return Get_Physical_Value (Expr); - when Iir_Kinds_Denoting_Name => - return Eval_Pos (Get_Named_Entity (Expr)); - when others => - Error_Kind ("eval_pos", Expr); - end case; - end Eval_Pos; - - function Eval_Static_Range (Rng : Iir) return Iir - is - Expr : Iir; - Kind : Iir_Kind; - begin - Expr := Rng; - loop - Kind := Get_Kind (Expr); - case Kind is - when Iir_Kind_Range_Expression => - if Get_Expr_Staticness (Expr) /= Locally then - return Null_Iir; - end if; - - -- Normalize the range expression. - declare - Left : Iir; - Right : Iir; - begin - Left := Get_Left_Limit_Expr (Expr); - if Is_Valid (Left) then - Left := Eval_Expr_Keep_Orig (Left, False); - Set_Left_Limit_Expr (Expr, Left); - Set_Left_Limit (Expr, Left); - end if; - Right := Get_Right_Limit_Expr (Expr); - if Is_Valid (Right) then - Right := Eval_Expr_Keep_Orig (Right, False); - Set_Right_Limit_Expr (Expr, Right); - Set_Right_Limit (Expr, Right); - end if; - end; - return Expr; - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition => - Expr := Get_Range_Constraint (Expr); - when Iir_Kind_Range_Array_Attribute - | Iir_Kind_Reverse_Range_Array_Attribute => - declare - Indexes_List : Iir_Flist; - Prefix : Iir; - Res : Iir; - Dim : Natural; - begin - Prefix := Get_Prefix (Expr); - if Get_Kind (Prefix) /= Iir_Kind_Array_Subtype_Definition - then - Prefix := Get_Type (Prefix); - end if; - if Get_Kind (Prefix) /= Iir_Kind_Array_Subtype_Definition - then - -- Unconstrained object. - return Null_Iir; - end if; - Indexes_List := Get_Index_Subtype_List (Prefix); - Dim := Eval_Attribute_Parameter_Or_1 (Expr); - if Dim < 1 - or else Dim > Get_Nbr_Elements (Indexes_List) - then - -- Avoid cascaded errors. - Dim := 1; - end if; - Expr := Get_Nth_Element (Indexes_List, Dim - 1); - if Kind = Iir_Kind_Reverse_Range_Array_Attribute then - Expr := Eval_Static_Range (Expr); - - Res := Create_Iir (Iir_Kind_Range_Expression); - Location_Copy (Res, Expr); - Set_Type (Res, Get_Type (Expr)); - case Get_Direction (Expr) is - when Iir_To => - Set_Direction (Res, Iir_Downto); - when Iir_Downto => - Set_Direction (Res, Iir_To); - end case; - Set_Left_Limit (Res, Get_Right_Limit (Expr)); - Set_Right_Limit (Res, Get_Left_Limit (Expr)); - Set_Range_Origin (Res, Rng); - Set_Expr_Staticness (Res, Get_Expr_Staticness (Expr)); - return Res; - end if; - end; - - when Iir_Kind_Subtype_Declaration - | Iir_Kind_Base_Attribute - | Iir_Kind_Subtype_Attribute - | Iir_Kind_Element_Attribute => - Expr := Get_Type (Expr); - when Iir_Kind_Type_Declaration => - Expr := Get_Type_Definition (Expr); - when Iir_Kind_Simple_Name - | Iir_Kind_Selected_Name => - Expr := Get_Named_Entity (Expr); - when others => - Error_Kind ("eval_static_range", Expr); - end case; - end loop; - end Eval_Static_Range; - - function Eval_Range (Arange : Iir) return Iir is - Res : Iir; - begin - Res := Eval_Static_Range (Arange); - if Res /= Arange - and then Get_Range_Origin (Res) /= Arange - then - return Build_Constant_Range (Res, Arange); - else - return Res; - end if; - end Eval_Range; - - function Eval_Range_If_Static (Arange : Iir) return Iir is - begin - if Get_Expr_Staticness (Arange) /= Locally then - return Arange; - else - return Eval_Range (Arange); - end if; - end Eval_Range_If_Static; - - -- Return the range constraint of a discrete range. - function Eval_Discrete_Range_Expression (Constraint : Iir) return Iir - is - Res : Iir; - begin - Res := Eval_Static_Range (Constraint); - if Res = Null_Iir then - Error_Kind ("eval_discrete_range_expression", Constraint); - else - return Res; - end if; - end Eval_Discrete_Range_Expression; - - function Eval_Discrete_Range_Left (Constraint : Iir) return Iir - is - Range_Expr : Iir; - begin - Range_Expr := Eval_Discrete_Range_Expression (Constraint); - return Get_Left_Limit (Range_Expr); - end Eval_Discrete_Range_Left; - - function Eval_Is_Eq (L, R : Iir) return Boolean - is - Expr_Type : constant Iir := Get_Type (L); - begin - case Get_Kind (Expr_Type) is - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Integer_Type_Definition - | Iir_Kind_Physical_Subtype_Definition - | Iir_Kind_Physical_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Enumeration_Type_Definition => - return Eval_Pos (L) = Eval_Pos (R); - when Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Floating_Type_Definition => - return Get_Fp_Value (L) = Get_Fp_Value (R); - when others => - Error_Kind ("eval_is_eq", Expr_Type); - end case; - end Eval_Is_Eq; - - function Eval_Operator_Symbol_Name (Id : Name_Id) return String is - begin - return '"' & Image (Id) & '"'; - end Eval_Operator_Symbol_Name; - - function Eval_Simple_Name (Id : Name_Id) return String is - begin - -- LRM 14.1 - -- E'SIMPLE_NAME - -- Result: [...] but with apostrophes (in the case of a character - -- literal) - if Is_Character (Id) then - return ''' & Get_Character (Id) & '''; - end if; - case Id is - when Std_Names.Name_Word_Operators - | Std_Names.Name_First_Operator .. Std_Names.Name_Last_Operator => - return Eval_Operator_Symbol_Name (Id); - when Std_Names.Name_Xnor - | Std_Names.Name_Shift_Operators => - if Flags.Vhdl_Std > Vhdl_87 then - return Eval_Operator_Symbol_Name (Id); - end if; - when others => - null; - end case; - return Image (Id); - end Eval_Simple_Name; - - package body String_Utils is - -- Fill Res from EL. This is used to speed up Lt and Eq operations. - function Get_Str_Info (Expr : Iir) return Str_Info is - begin - case Get_Kind (Expr) is - when Iir_Kind_Simple_Aggregate => - declare - List : constant Iir_Flist := - Get_Simple_Aggregate_List (Expr); - begin - return Str_Info'(Is_String => False, - Len => Nat32 (Get_Nbr_Elements (List)), - List => List); - end; - when Iir_Kind_String_Literal8 => - return Str_Info'(Is_String => True, - Len => Get_String_Length (Expr), - Id => Get_String8_Id (Expr)); - when others => - Error_Kind ("string_utils.get_info", Expr); - end case; - end Get_Str_Info; - - -- Return the position of element IDX of STR. - function Get_Pos (Str : Str_Info; Idx : Nat32) return Iir_Int32 - is - S : Iir; - P : Nat32; - begin - case Str.Is_String is - when False => - S := Get_Nth_Element (Str.List, Natural (Idx)); - return Get_Enum_Pos (S); - when True => - P := Str_Table.Element_String8 (Str.Id, Idx + 1); - return Iir_Int32 (P); - end case; - end Get_Pos; - end String_Utils; - - function Compare_String_Literals (L, R : Iir) return Compare_Type - is - use String_Utils; - L_Info : constant Str_Info := Get_Str_Info (L); - R_Info : constant Str_Info := Get_Str_Info (R); - L_Pos, R_Pos : Iir_Int32; - begin - if L_Info.Len /= R_Info.Len then - raise Internal_Error; - end if; - - for I in 0 .. L_Info.Len - 1 loop - L_Pos := Get_Pos (L_Info, I); - R_Pos := Get_Pos (R_Info, I); - if L_Pos /= R_Pos then - if L_Pos < R_Pos then - return Compare_Lt; - else - return Compare_Gt; - end if; - end if; - end loop; - return Compare_Eq; - end Compare_String_Literals; - - function Get_Path_Instance_Name_Suffix (Attr : Iir) - return Path_Instance_Name_Type - is - -- Current path for name attributes. - Path_Str : String_Acc := null; - Path_Maxlen : Natural := 0; - Path_Len : Natural; - Path_Instance : Iir; - - procedure Deallocate is new Ada.Unchecked_Deallocation - (Name => String_Acc, Object => String); - - procedure Path_Reset is - begin - Path_Len := 0; - Path_Instance := Null_Iir; - if Path_Maxlen = 0 then - Path_Maxlen := 256; - Path_Str := new String (1 .. Path_Maxlen); - end if; - end Path_Reset; - - procedure Path_Add (Str : String) - is - N_Len : Natural; - N_Path : String_Acc; - begin - N_Len := Path_Maxlen; - loop - exit when Path_Len + Str'Length <= N_Len; - N_Len := N_Len * 2; - end loop; - if N_Len /= Path_Maxlen then - N_Path := new String (1 .. N_Len); - N_Path (1 .. Path_Len) := Path_Str (1 .. Path_Len); - Deallocate (Path_Str); - Path_Str := N_Path; - Path_Maxlen := N_Len; - end if; - Path_Str (Path_Len + 1 .. Path_Len + Str'Length) := Str; - Path_Len := Path_Len + Str'Length; - end Path_Add; - - procedure Path_Add_Type_Name (Atype : Iir) - is - Adecl : constant Iir := Get_Type_Declarator (Atype); - begin - Path_Add (Image (Get_Identifier (Adecl))); - end Path_Add_Type_Name; - - procedure Path_Add_Signature (Subprg : Iir) - is - Chain : Iir; - begin - Path_Add ("["); - Chain := Get_Interface_Declaration_Chain (Subprg); - while Chain /= Null_Iir loop - Path_Add_Type_Name (Get_Type (Chain)); - Chain := Get_Chain (Chain); - if Chain /= Null_Iir then - Path_Add (","); - end if; - end loop; - - case Get_Kind (Subprg) is - when Iir_Kind_Function_Declaration => - Path_Add (" return "); - Path_Add_Type_Name (Get_Return_Type (Subprg)); - when others => - null; - end case; - Path_Add ("]"); - end Path_Add_Signature; - - procedure Path_Add_Name (N : Iir) - is - Img : constant String := Eval_Simple_Name (Get_Identifier (N)); - begin - if Img (Img'First) /= 'P' then - -- Skip anonymous processes. - Path_Add (Img); - end if; - end Path_Add_Name; - - procedure Path_Add_Element (El : Iir; Is_Instance : Boolean) is - begin - -- LRM 14.1 - -- E'INSTANCE_NAME - -- There is one full path instance element for each component - -- instantiation, block statement, generate statemenent, process - -- statement, or subprogram body in the design hierarchy between - -- the top design entity and the named entity denoted by the - -- prefix. - -- - -- E'PATH_NAME - -- There is one path instance element for each component - -- instantiation, block statement, generate statement, process - -- statement, or subprogram body in the design hierarchy between - -- the root design entity and the named entity denoted by the - -- prefix. - case Get_Kind (El) is - when Iir_Kind_Library_Declaration => - Path_Add (":"); - Path_Add_Name (El); - Path_Add (":"); - when Iir_Kind_Package_Declaration - | Iir_Kind_Package_Body - | Iir_Kind_Package_Instantiation_Declaration => - if Is_Nested_Package (El) then - Path_Add_Element (Get_Parent (El), Is_Instance); - else - Path_Add_Element - (Get_Library (Get_Design_File (Get_Design_Unit (El))), - Is_Instance); - end if; - Path_Add_Name (El); - Path_Add (":"); - when Iir_Kind_Entity_Declaration => - Path_Instance := El; - when Iir_Kind_Architecture_Body => - Path_Instance := El; - when Iir_Kind_Design_Unit => - Path_Add_Element (Get_Library_Unit (El), Is_Instance); - when Iir_Kind_Sensitized_Process_Statement - | Iir_Kind_Process_Statement - | Iir_Kind_Block_Statement - | Iir_Kind_Protected_Type_Body => - Path_Add_Element (Get_Parent (El), Is_Instance); - Path_Add_Name (El); - Path_Add (":"); - when Iir_Kind_Protected_Type_Declaration => - declare - Decl : constant Iir := Get_Type_Declarator (El); - begin - Path_Add_Element (Get_Parent (Decl), Is_Instance); - Path_Add_Name (Decl); - Path_Add (":"); - end; - when Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration => - Path_Add_Element (Get_Parent (El), Is_Instance); - Path_Add_Name (El); - if Flags.Vhdl_Std >= Vhdl_02 then - -- Add signature. - Path_Add_Signature (El); - end if; - Path_Add (":"); - when Iir_Kind_Procedure_Body => - Path_Add_Element (Get_Subprogram_Specification (El), - Is_Instance); - when Iir_Kind_For_Generate_Statement => - Path_Instance := El; - when Iir_Kind_If_Generate_Statement => - Path_Add_Element (Get_Parent (El), Is_Instance); - Path_Add_Name (El); - Path_Add (":"); - when Iir_Kind_Generate_Statement_Body => - declare - Parent : constant Iir := Get_Parent (El); - begin - if Get_Kind (Parent) = Iir_Kind_For_Generate_Statement then - Path_Instance := El; - else - Path_Add_Element (Parent, Is_Instance); - end if; - end; - when Iir_Kinds_Sequential_Statement => - Path_Add_Element (Get_Parent (El), Is_Instance); - when others => - Error_Kind ("path_add_element", El); - end case; - end Path_Add_Element; - - Prefix : constant Iir := Get_Named_Entity (Get_Prefix (Attr)); - Is_Instance : constant Boolean := - Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; - begin - Path_Reset; - - -- LRM 14.1 - -- E'PATH_NAME - -- The local item name in E'PATH_NAME equals E'SIMPLE_NAME, unless - -- E denotes a library, package, subprogram or label. In this - -- latter case, the package based path or instance based path, - -- as appropriate, will not contain a local item name. - -- - -- E'INSTANCE_NAME - -- The local item name in E'INSTANCE_NAME equals E'SIMPLE_NAME, - -- unless E denotes a library, package, subprogram, or label. In - -- this latter case, the package based path or full instance based - -- path, as appropriate, will not contain a local item name. - case Get_Kind (Prefix) is - when Iir_Kind_Constant_Declaration - | Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Iterator_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Signal_Declaration - | Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_File_Declaration - | Iir_Kind_Interface_File_Declaration - | Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration => - Path_Add_Element (Get_Parent (Prefix), Is_Instance); - Path_Add_Name (Prefix); - when Iir_Kind_Library_Declaration - | Iir_Kinds_Library_Unit - | Iir_Kind_Function_Declaration - | Iir_Kind_Procedure_Declaration - | Iir_Kinds_Concurrent_Statement - | Iir_Kinds_Sequential_Statement => - Path_Add_Element (Prefix, Is_Instance); - when others => - Error_Kind ("get_path_instance_name_suffix", Prefix); - end case; - - declare - Result : constant Path_Instance_Name_Type := - (Len => Path_Len, - Path_Instance => Path_Instance, - Suffix => Path_Str (1 .. Path_Len)); - begin - Deallocate (Path_Str); - return Result; - end; - end Get_Path_Instance_Name_Suffix; - -end Evaluation; diff --git a/src/vhdl/evaluation.ads b/src/vhdl/evaluation.ads deleted file mode 100644 index 09975cd6a..000000000 --- a/src/vhdl/evaluation.ads +++ /dev/null @@ -1,218 +0,0 @@ --- Evaluation of static expressions. --- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold --- --- GHDL is free software; you can redistribute it and/or modify it under --- the terms of the GNU General Public License as published by the Free --- Software Foundation; either version 2, or (at your option) any later --- version. --- --- GHDL 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. See the GNU General Public License --- for more details. --- --- You should have received a copy of the GNU General Public License --- along with GHDL; see the file COPYING. If not, write to the Free --- Software Foundation, 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. -with Types; use Types; -with Iirs; use Iirs; - -package Evaluation is - - -- Evaluation is about compile-time computation of expressions, such as - -- 2 + 1 --> 3. This is (of course) possible only with locally (and some - -- globally) static expressions. Evaluation is required during semantic - -- analysis at many places (in fact those where locally static expression - -- are required by the language). For example, the type of O'Range (N) - -- depends on N, so we need to evaluate N. - -- - -- The result of evaluation is a literal (integer, enumeration, real, - -- physical), a string or a simple aggregate. For scalar types, the - -- result is therefore normalized (there is only one kind of result), but - -- for array types, the result isn't: in general it will be a string, but - -- it may be a simple aggregate. Strings are preferred (because they are - -- more compact), but aren't possible in some cases. For example, the - -- evaluation of "Text" & NUL cannot be a string. - -- - -- Some functions (like Eval_Static_Expr) simply returns a result (which - -- may be a node of the expression), others returns a result and set the - -- origin (Literal_Origin or Range_Origin) to remember the original - -- expression that was evaluation. The original expression is kept so that - -- it is possible to print the original tree. - - -- Get the value of a physical integer literal or unit. May propagate - -- Constraint_Error. - function Get_Physical_Value (Expr : Iir) return Iir_Int64; - - -- Get the parameter of an attribute, or 1 if doesn't exist. - function Eval_Attribute_Parameter_Or_1 (Attr : Iir) return Natural; - - -- Evaluate the locally static expression EXPR (without checking that EXPR - -- is locally static). Return a literal or an aggregate, without setting - -- the origin, and do not modify EXPR. This can be used only to get the - -- value of an expression, without replacing it. - function Eval_Static_Expr (Expr: Iir) return Iir; - - -- Evaluate (ie compute) expression EXPR. - -- EXPR is required to be a locally static expression, otherwise an error - -- message is generated. - -- The result is a literal with the origin set. - function Eval_Expr (Expr: Iir) return Iir; - - -- Same as Eval_Expr, but if EXPR is not locally static, the result is - -- EXPR. Also, if EXPR is null_iir, then null_iir is returned. - -- The purpose of this function is to evaluate an expression only if it - -- is locally static. - function Eval_Expr_If_Static (Expr : Iir) return Iir; - - -- Evaluate a physical literal and return a normalized literal (using - -- the primary unit as unit). - function Eval_Physical_Literal (Expr : Iir) return Iir; - - -- Return TRUE if literal EXPR is in SUB_TYPE bounds. - function Eval_Is_In_Bound (Expr : Iir; Sub_Type : Iir) return Boolean; - - -- Emit an error if EXPR violates SUB_TYPE bounds. - procedure Eval_Check_Bound (Expr : Iir; Sub_Type : Iir); - - -- Same as Eval_Expr, but a range check with SUB_TYPE is performed after - -- computation. - function Eval_Expr_Check (Expr : Iir; Sub_Type : Iir) return Iir; - - -- Call Eval_Expr_Check only if EXPR is static. - function Eval_Expr_Check_If_Static (Expr : Iir; Atype : Iir) return Iir; - - -- For a locally static range RNG (a range expression, a range attribute - -- or a name that denotes a type or a subtype) returns its corresponding - -- locally static range_expression. The bounds of the results are also - -- literals. - -- Return a range_expression or NULL_IIR for a non locally static range. - function Eval_Static_Range (Rng : Iir) return Iir; - - -- Return a locally static range expression with the origin set for ARANGE. - function Eval_Range (Arange : Iir) return Iir; - - -- If ARANGE is a locally static range, return locally static range - -- expression (with the origin set), else return ARANGE. - function Eval_Range_If_Static (Arange : Iir) return Iir; - - -- Emit an error if A_RANGE is not included in SUB_TYPE. A_RANGE can be - -- a range expression, a range attribute or a name that denotes a discrete - -- type or subtype. A_RANGE must be a locally static range. - procedure Eval_Check_Range (A_Range : Iir; Sub_Type : Iir; - Any_Dir : Boolean); - - -- Return TRUE if A_RANGE is compatible with SUB_TYPE. Compatibility is - -- defined in LRM: - -- - -- LRM08 5.2 Scalar types - -- A range constraint is /compatible/ with a subtype if each bound of the - -- range belongs to the subtype or if the range constraint defines a null - -- range. - function Eval_Is_Range_In_Bound - (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean) - return Boolean; - - -- Return TRUE iff VAL belongs to BOUND. - function Eval_Int_In_Range (Val : Iir_Int64; Bound : Iir) return Boolean; - - -- Return the length of the discrete range CONSTRAINT. - function Eval_Discrete_Range_Length (Constraint : Iir) return Iir_Int64; - - -- Return the length of SUB_TYPE. - function Eval_Discrete_Type_Length (Sub_Type : Iir) return Iir_Int64; - - -- Get the left bound of a range constraint. - -- Note: the range constraint may be an attribute or a subtype. - function Eval_Discrete_Range_Left (Constraint : Iir) return Iir; - - -- Return the position of EXPR, ie the result of sub_type'pos (EXPR), where - -- sub_type is the type of expr. - -- EXPR must be of a discrete subtype. - function Eval_Pos (Expr : Iir) return Iir_Int64; - - -- Return True iff L and R (scalar literals) are equal. - function Eval_Is_Eq (L, R : Iir) return Boolean; - - -- Replace ORIGIN (an overflow literal) with extreme positive value (if - -- IS_POS is true) or extreme negative value. - function Build_Extreme_Value (Is_Pos : Boolean; Origin : Iir) return Iir; - - -- Create a Iir_Kind_Overflow node of type EXPR_TYPE for ORIGIN. - function Build_Overflow (Origin : Iir; Expr_Type : Iir) return Iir; - - -- Fill VECT with choices from CHOICES_CHAIN: each position of CHOICE_RANGE - -- is associated with its corresponding choice from CHOICES_CHAIN. - -- VECT bounds must be 0 .. Len - 1, where Len is the length of - -- CHOICE_RANGE. - procedure Build_Array_Choices_Vector - (Vect : out Iir_Array; Choice_Range : Iir; Choices_Chain : Iir); - - -- Create an array subtype from LEN and BASE_TYPE, according to rules - -- of LRM93 7.3.2.2. (which are the same as LRM93 7.2.4). - function Create_Unidim_Array_By_Length - (Base_Type : Iir; Len : Iir_Int64; Loc : Iir) - return Iir_Array_Subtype_Definition; - - -- Create a subtype of A_TYPE whose length is LEN. - -- This is used to create subtypes for strings or aggregates. - function Create_Range_Subtype_By_Length - (A_Type : Iir; Len : Iir_Int64; Loc : Location_Type) - return Iir; - - -- Compute ATYPE'value (VALUE) using origin ORIG, but without checking - -- bounds. - function Eval_Value_Attribute - (Value : String; Atype : Iir; Orig : Iir) return Iir; - - -- From one-dimensional array expression PREFIX extract element at - -- offset OFF (from 0 to length - 1). Note that the element is directly - -- returned, not a copy of it (so it should be referenced if stored in - -- the tree). - function Eval_Indexed_Name_By_Offset (Prefix : Iir; Off : Iir_Index32) - return Iir; - - -- Return the simple name, character literal or operator sumbol of ID, - -- using the same format as SIMPLE_NAME attribute. - function Eval_Simple_Name (Id : Name_Id) return String; - - -- Compare two string literals (of same length). - type Compare_Type is (Compare_Lt, Compare_Eq, Compare_Gt); - function Compare_String_Literals (L, R : Iir) return Compare_Type; - - package String_Utils is - type Str_Info (Is_String : Boolean := True) is record - Len : Nat32; - - case Is_String is - when True => - Id : String8_Id; - when False => - -- A simple aggregate. List of elements. - List : Iir_Flist; - end case; - end record; - - -- Fill Res from EL. This is used to speed up Lt and Eq operations. - function Get_Str_Info (Expr : Iir) return Str_Info; - - -- Return the position of element IDX of STR. - function Get_Pos (Str : Str_Info; Idx : Nat32) return Iir_Int32; - end String_Utils; - - -- Return the local part of 'Instance_Name or 'Path_Name. - type Path_Instance_Name_Type (Len : Natural) is record - -- The node before suffix (entity, architecture or generate iterator). - Path_Instance : Iir; - - -- The suffix - Suffix : String (1 .. Len); - end record; - - function Get_Path_Instance_Name_Suffix (Attr : Iir) - return Path_Instance_Name_Type; - - -- Create a copy of VAL. - function Copy_Constant (Val : Iir) return Iir; -end Evaluation; diff --git a/src/vhdl/simulate/simul-elaboration.adb b/src/vhdl/simulate/simul-elaboration.adb index 3addbef91..a961aeeae 100644 --- a/src/vhdl/simulate/simul-elaboration.adb +++ b/src/vhdl/simulate/simul-elaboration.adb @@ -19,7 +19,7 @@ with Ada.Text_IO; with Str_Table; with Errorout; use Errorout; -with Evaluation; +with Vhdl.Evaluation; with Simul.Execution; use Simul.Execution; with Iirs_Utils; use Iirs_Utils; with Libraries; @@ -2861,7 +2861,7 @@ package body Simul.Elaboration is function Override_Generic (Formal : Iir; Str : String) return Iir is - use Evaluation; + use Vhdl.Evaluation; Formal_Type : constant Iir := Get_Type (Formal); Formal_Btype : constant Iir := Get_Base_Type (Formal_Type); Res : Iir; diff --git a/src/vhdl/simulate/simul-execution.adb b/src/vhdl/simulate/simul-execution.adb index 59d91c8ef..d40a093cb 100644 --- a/src/vhdl/simulate/simul-execution.adb +++ b/src/vhdl/simulate/simul-execution.adb @@ -23,7 +23,7 @@ with Grt.Types; use Grt.Types; with Flags; use Flags; with Errorout; use Errorout; with Vhdl.Std_Package; -with Evaluation; +with Vhdl.Evaluation; with Iirs_Utils; use Iirs_Utils; with Simul.Annotations; use Simul.Annotations; with Name_Table; @@ -361,7 +361,7 @@ package body Simul.Execution is function Execute_Path_Instance_Name_Attribute (Block : Block_Instance_Acc; Attr : Iir) return Iir_Value_Literal_Acc is - use Evaluation; + use Vhdl.Evaluation; use Grt.Vstrings; use Name_Table; @@ -1420,7 +1420,7 @@ package body Simul.Execution is begin Unit := Get_Unit_Chain (Vhdl.Std_Package.Time_Type_Definition); while Unit /= Null_Iir loop - exit when Evaluation.Get_Physical_Value (Unit) + exit when Vhdl.Evaluation.Get_Physical_Value (Unit) = Iir_Int64 (Right.I64); Unit := Get_Chain (Unit); end loop; @@ -2279,7 +2279,7 @@ package body Simul.Execution is is Prefix : constant Iir := Strip_Denoting_Name (Get_Prefix (Attr)); Dim : constant Natural := - Evaluation.Eval_Attribute_Parameter_Or_1 (Attr); + Vhdl.Evaluation.Eval_Attribute_Parameter_Or_1 (Attr); begin case Get_Kind (Prefix) is when Iir_Kind_Type_Declaration @@ -3076,7 +3076,7 @@ package body Simul.Execution is | Iir_Kind_Physical_Fp_Literal | Iir_Kind_Unit_Declaration => return Create_I64_Value - (Ghdl_I64 (Evaluation.Get_Physical_Value (Expr))); + (Ghdl_I64 (Vhdl.Evaluation.Get_Physical_Value (Expr))); when Iir_Kind_String_Literal8 => return Execute_String_Literal (Expr, Block); @@ -4380,7 +4380,7 @@ package body Simul.Execution is Get_Type (Get_Choice_Expression (Assoc)); Choice_Len : Iir_Int64; begin - Choice_Len := Evaluation.Eval_Discrete_Type_Length + Choice_Len := Vhdl.Evaluation.Eval_Discrete_Type_Length (Get_String_Type_Bound_Type (Choice_Type)); if Choice_Len /= Iir_Int64 (Value.Bounds.D (1).Length) then Error_Msg_Constraint (Expr); diff --git a/src/vhdl/translate/trans-chap14.adb b/src/vhdl/translate/trans-chap14.adb index b8e8f71fe..df6b937e3 100644 --- a/src/vhdl/translate/trans-chap14.adb +++ b/src/vhdl/translate/trans-chap14.adb @@ -16,7 +16,7 @@ -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. -with Evaluation; use Evaluation; +with Vhdl.Evaluation; use Vhdl.Evaluation; with Vhdl.Std_Package; use Vhdl.Std_Package; with Errorout; use Errorout; with Iirs_Utils; use Iirs_Utils; diff --git a/src/vhdl/translate/trans-chap3.adb b/src/vhdl/translate/trans-chap3.adb index 66e897660..f9685f284 100644 --- a/src/vhdl/translate/trans-chap3.adb +++ b/src/vhdl/translate/trans-chap3.adb @@ -19,7 +19,7 @@ with Name_Table; with Errorout; use Errorout; with Iirs_Utils; use Iirs_Utils; -with Evaluation; use Evaluation; +with Vhdl.Evaluation; use Vhdl.Evaluation; with Trans.Chap2; with Trans.Chap4; with Trans.Chap6; diff --git a/src/vhdl/translate/trans-chap6.adb b/src/vhdl/translate/trans-chap6.adb index a1c8fa658..383dd8ce8 100644 --- a/src/vhdl/translate/trans-chap6.adb +++ b/src/vhdl/translate/trans-chap6.adb @@ -19,7 +19,7 @@ with Files_Map; with Errorout; use Errorout; with Iirs_Utils; use Iirs_Utils; -with Evaluation; use Evaluation; +with Vhdl.Evaluation; use Vhdl.Evaluation; with Trans.Chap3; with Trans.Chap7; with Trans.Chap14; diff --git a/src/vhdl/translate/trans-chap7.adb b/src/vhdl/translate/trans-chap7.adb index a9838e769..ebde37648 100644 --- a/src/vhdl/translate/trans-chap7.adb +++ b/src/vhdl/translate/trans-chap7.adb @@ -25,7 +25,7 @@ with Vhdl.Std_Package; use Vhdl.Std_Package; with Errorout; use Errorout; with Flags; use Flags; with Vhdl.Canon; -with Evaluation; use Evaluation; +with Vhdl.Evaluation; use Vhdl.Evaluation; with Trans.Chap3; with Trans.Chap4; with Trans.Chap6; diff --git a/src/vhdl/translate/trans-chap8.adb b/src/vhdl/translate/trans-chap8.adb index f78a3d45a..4819a0e16 100644 --- a/src/vhdl/translate/trans-chap8.adb +++ b/src/vhdl/translate/trans-chap8.adb @@ -21,7 +21,7 @@ with Std_Names; with Errorout; use Errorout; with Iir_Chains; with Vhdl.Canon; -with Evaluation; use Evaluation; +with Vhdl.Evaluation; use Vhdl.Evaluation; with Vhdl.Std_Package; use Vhdl.Std_Package; with Iirs_Utils; use Iirs_Utils; with Trans.Chap2; diff --git a/src/vhdl/vhdl-evaluation.adb b/src/vhdl/vhdl-evaluation.adb new file mode 100644 index 000000000..11776b1b6 --- /dev/null +++ b/src/vhdl/vhdl-evaluation.adb @@ -0,0 +1,3994 @@ +-- Evaluation of static expressions. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL 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. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Ada.Unchecked_Deallocation; +with Interfaces; +with Vhdl.Scanner; +with Errorout; use Errorout; +with Name_Table; use Name_Table; +with Str_Table; +with Iirs_Utils; use Iirs_Utils; +with Vhdl.Std_Package; use Vhdl.Std_Package; +with Flags; use Flags; +with Std_Names; +with Ada.Characters.Handling; +with Grt.Fcvt; + +package body Vhdl.Evaluation is + -- If FORCE is true, always return a literal. + function Eval_Expr_Keep_Orig (Expr : Iir; Force : Boolean) return Iir; + + function Eval_Enum_To_String (Lit : Iir; Orig : Iir) return Iir; + function Eval_Integer_Image (Val : Iir_Int64; Orig : Iir) return Iir; + + function Eval_Scalar_Compare (Left, Right : Iir) return Compare_Type; + + function Get_Physical_Value (Expr : Iir) return Iir_Int64 + is + pragma Unsuppress (Overflow_Check); + Kind : constant Iir_Kind := Get_Kind (Expr); + Unit : Iir; + begin + case Kind is + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal => + -- Extract Unit. + Unit := Get_Physical_Literal (Get_Physical_Unit (Expr)); + pragma Assert (Get_Physical_Unit (Unit) + = Get_Primary_Unit (Get_Type (Unit))); + case Kind is + when Iir_Kind_Physical_Int_Literal => + return Get_Value (Expr) * Get_Value (Unit); + when Iir_Kind_Physical_Fp_Literal => + return Iir_Int64 + (Get_Fp_Value (Expr) * Iir_Fp64 (Get_Value (Unit))); + when others => + raise Program_Error; + end case; + when Iir_Kind_Unit_Declaration => + return Get_Value (Get_Physical_Literal (Expr)); + when others => + Error_Kind ("get_physical_value", Expr); + end case; + end Get_Physical_Value; + + function Build_Integer (Val : Iir_Int64; Origin : Iir) + return Iir_Integer_Literal + is + Res : Iir_Integer_Literal; + begin + Res := Create_Iir (Iir_Kind_Integer_Literal); + Location_Copy (Res, Origin); + Set_Value (Res, Val); + Set_Type (Res, Get_Type (Origin)); + Set_Literal_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + return Res; + end Build_Integer; + + function Build_Floating (Val : Iir_Fp64; Origin : Iir) + return Iir_Floating_Point_Literal + is + Res : Iir_Floating_Point_Literal; + begin + Res := Create_Iir (Iir_Kind_Floating_Point_Literal); + Location_Copy (Res, Origin); + Set_Fp_Value (Res, Val); + Set_Type (Res, Get_Type (Origin)); + Set_Literal_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + return Res; + end Build_Floating; + + function Build_Enumeration_Constant (Val : Iir_Index32; Origin : Iir) + return Iir_Enumeration_Literal + is + Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); + Enum_List : constant Iir_Flist := + Get_Enumeration_Literal_List (Enum_Type); + Lit : constant Iir_Enumeration_Literal := + Get_Nth_Element (Enum_List, Integer (Val)); + Res : Iir_Enumeration_Literal; + begin + Res := Copy_Enumeration_Literal (Lit); + Location_Copy (Res, Origin); + Set_Literal_Origin (Res, Origin); + return Res; + end Build_Enumeration_Constant; + + function Build_Physical (Val : Iir_Int64; Origin : Iir) + return Iir_Physical_Int_Literal + is + Res : Iir_Physical_Int_Literal; + Unit_Name : Iir; + begin + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Location_Copy (Res, Origin); + Unit_Name := Get_Primary_Unit (Get_Base_Type (Get_Type (Origin))); + Set_Physical_Unit (Res, Unit_Name); + Set_Value (Res, Val); + Set_Type (Res, Get_Type (Origin)); + Set_Literal_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + return Res; + end Build_Physical; + + function Build_Discrete (Val : Iir_Int64; Origin : Iir) return Iir is + begin + case Get_Kind (Get_Type (Origin)) is + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + return Build_Enumeration_Constant (Iir_Index32 (Val), Origin); + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + return Build_Integer (Val, Origin); + when others => + Error_Kind ("build_discrete", Get_Type (Origin)); + end case; + end Build_Discrete; + + function Build_String (Val : String8_Id; Len : Nat32; Origin : Iir) + return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_String_Literal8); + Location_Copy (Res, Origin); + Set_String8_Id (Res, Val); + Set_String_Length (Res, Len); + Set_Type (Res, Get_Type (Origin)); + Set_Literal_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + return Res; + end Build_String; + + -- Build a simple aggregate composed of EL_LIST from ORIGIN. STYPE is the + -- type of the aggregate. DEF_TYPE should be either Null_Iir or STYPE. It + -- is set only when a new subtype has been created for the aggregate. + function Build_Simple_Aggregate (El_List : Iir_Flist; + Origin : Iir; + Stype : Iir; + Def_Type : Iir := Null_Iir) + return Iir_Simple_Aggregate + is + Res : Iir_Simple_Aggregate; + begin + Res := Create_Iir (Iir_Kind_Simple_Aggregate); + Location_Copy (Res, Origin); + Set_Simple_Aggregate_List (Res, El_List); + Set_Type (Res, Stype); + Set_Literal_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + Set_Literal_Subtype (Res, Def_Type); + return Res; + end Build_Simple_Aggregate; + + function Build_Overflow (Origin : Iir; Expr_Type : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Overflow_Literal); + Location_Copy (Res, Origin); + Set_Type (Res, Expr_Type); + Set_Literal_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + return Res; + end Build_Overflow; + + function Build_Overflow (Origin : Iir) return Iir is + begin + return Build_Overflow (Origin, Get_Type (Origin)); + end Build_Overflow; + + function Build_Constant (Val : Iir; Origin : Iir) return Iir + is + Res : Iir; + begin + -- Note: this must work for any literals, because it may be used to + -- replace a locally static constant by its initial value. + case Get_Kind (Val) is + when Iir_Kind_Integer_Literal => + Res := Create_Iir (Iir_Kind_Integer_Literal); + Set_Value (Res, Get_Value (Val)); + + when Iir_Kind_Floating_Point_Literal => + Res := Create_Iir (Iir_Kind_Floating_Point_Literal); + Set_Fp_Value (Res, Get_Fp_Value (Val)); + + when Iir_Kind_Enumeration_Literal => + return Build_Enumeration_Constant + (Iir_Index32 (Get_Enum_Pos (Val)), Origin); + + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal => + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Set_Physical_Unit (Res, Get_Primary_Unit + (Get_Base_Type (Get_Type (Origin)))); + Set_Value (Res, Get_Physical_Value (Val)); + + when Iir_Kind_Unit_Declaration => + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Set_Value (Res, Get_Physical_Value (Val)); + Set_Physical_Unit (Res, Get_Primary_Unit (Get_Type (Val))); + + when Iir_Kind_String_Literal8 => + Res := Create_Iir (Iir_Kind_String_Literal8); + Set_String8_Id (Res, Get_String8_Id (Val)); + Set_String_Length (Res, Get_String_Length (Val)); + + when Iir_Kind_Simple_Aggregate => + Res := Create_Iir (Iir_Kind_Simple_Aggregate); + Set_Simple_Aggregate_List (Res, Get_Simple_Aggregate_List (Val)); + + when Iir_Kind_Overflow_Literal => + Res := Create_Iir (Iir_Kind_Overflow_Literal); + + when others => + Error_Kind ("build_constant", Val); + end case; + Location_Copy (Res, Origin); + Set_Type (Res, Get_Type (Origin)); + Set_Literal_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + return Res; + end Build_Constant; + + function Copy_Constant (Val : Iir) return Iir + is + Res : Iir; + begin + Res := Build_Constant (Val, Val); + Set_Literal_Origin (Res, Null_Iir); + return Res; + end Copy_Constant; + + -- FIXME: origin ? + function Build_Boolean (Cond : Boolean) return Iir is + begin + if Cond then + return Boolean_True; + else + return Boolean_False; + end if; + end Build_Boolean; + + function Build_Enumeration (Val : Iir_Index32; Origin : Iir) + return Iir_Enumeration_Literal + is + Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); + Enum_List : constant Iir_Flist := + Get_Enumeration_Literal_List (Enum_Type); + begin + return Get_Nth_Element (Enum_List, Integer (Val)); + end Build_Enumeration; + + function Build_Enumeration (Val : Boolean; Origin : Iir) + return Iir_Enumeration_Literal + is + Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); + Enum_List : constant Iir_Flist := + Get_Enumeration_Literal_List (Enum_Type); + begin + return Get_Nth_Element (Enum_List, Boolean'Pos (Val)); + end Build_Enumeration; + + function Build_Constant_Range (Range_Expr : Iir; Origin : Iir) return Iir + is + Res : Iir; + begin + Res := Create_Iir (Iir_Kind_Range_Expression); + Location_Copy (Res, Origin); + Set_Type (Res, Get_Type (Range_Expr)); + Set_Left_Limit (Res, Get_Left_Limit (Range_Expr)); + Set_Right_Limit (Res, Get_Right_Limit (Range_Expr)); + Set_Direction (Res, Get_Direction (Range_Expr)); + Set_Range_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + return Res; + end Build_Constant_Range; + + function Build_Extreme_Value (Is_Pos : Boolean; Origin : Iir) return Iir + is + Orig_Type : constant Iir := Get_Base_Type (Get_Type (Origin)); + begin + case Get_Kind (Orig_Type) is + when Iir_Kind_Integer_Type_Definition => + if Is_Pos then + return Build_Integer (Iir_Int64'Last, Origin); + else + return Build_Integer (Iir_Int64'First, Origin); + end if; + when others => + Error_Kind ("build_extreme_value", Orig_Type); + end case; + end Build_Extreme_Value; + + -- A_RANGE is a range expression, whose type, location, expr_staticness, + -- left_limit and direction are set. + -- Type of A_RANGE must have a range_constraint. + -- Set the right limit of A_RANGE from LEN. + procedure Set_Right_Limit_By_Length (A_Range : Iir; Len : Iir_Int64) + is + A_Type : constant Iir := Get_Type (A_Range); + Left : constant Iir := Get_Left_Limit (A_Range); + Right : Iir; + Pos : Iir_Int64; + begin + pragma Assert (Get_Expr_Staticness (A_Range) = Locally); + + Pos := Eval_Pos (Left); + case Get_Direction (A_Range) is + when Iir_To => + Pos := Pos + Len - 1; + when Iir_Downto => + Pos := Pos - Len + 1; + end case; + if Len > 0 + and then not Eval_Int_In_Range (Pos, Get_Range_Constraint (A_Type)) + then + Error_Msg_Sem (+A_Range, "range length is beyond subtype length"); + Right := Left; + else + -- FIXME: what about nul range? + Right := Build_Discrete (Pos, A_Range); + Set_Literal_Origin (Right, Null_Iir); + Set_Right_Limit_Expr (A_Range, Right); + end if; + Set_Right_Limit (A_Range, Right); + end Set_Right_Limit_By_Length; + + -- Create a range of type A_TYPE whose length is LEN. + -- Note: only two nodes are created: + -- * the range_expression (node returned) + -- * the right bound + -- The left bound *IS NOT* created, but points to the left bound of A_TYPE. + function Create_Range_By_Length + (A_Type : Iir; Len : Iir_Int64; Loc : Location_Type) + return Iir + is + Index_Constraint : Iir; + Constraint : Iir; + begin + -- The left limit must be locally static in order to compute the right + -- limit. + pragma Assert (Get_Type_Staticness (A_Type) = Locally); + + Index_Constraint := Get_Range_Constraint (A_Type); + Constraint := Create_Iir (Iir_Kind_Range_Expression); + Set_Location (Constraint, Loc); + Set_Expr_Staticness (Constraint, Locally); + Set_Type (Constraint, A_Type); + Set_Left_Limit (Constraint, Get_Left_Limit (Index_Constraint)); + Set_Direction (Constraint, Get_Direction (Index_Constraint)); + Set_Right_Limit_By_Length (Constraint, Len); + return Constraint; + end Create_Range_By_Length; + + function Create_Range_Subtype_From_Type (A_Type : Iir; Loc : Location_Type) + return Iir + is + Res : Iir; + begin + pragma Assert (Get_Type_Staticness (A_Type) = Locally); + + case Get_Kind (A_Type) is + when Iir_Kind_Enumeration_Type_Definition => + Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition); + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + Res := Create_Iir (Get_Kind (A_Type)); + when others => + Error_Kind ("create_range_subtype_by_length", A_Type); + end case; + Set_Location (Res, Loc); + Set_Base_Type (Res, Get_Base_Type (A_Type)); + Set_Type_Staticness (Res, Locally); + + return Res; + end Create_Range_Subtype_From_Type; + + -- Create a subtype of A_TYPE whose length is LEN. + -- This is used to create subtypes for strings or aggregates. + function Create_Range_Subtype_By_Length + (A_Type : Iir; Len : Iir_Int64; Loc : Location_Type) + return Iir + is + Res : Iir; + begin + Res := Create_Range_Subtype_From_Type (A_Type, Loc); + + Set_Range_Constraint (Res, Create_Range_By_Length (A_Type, Len, Loc)); + return Res; + end Create_Range_Subtype_By_Length; + + function Create_Unidim_Array_From_Index + (Base_Type : Iir; Index_Type : Iir; Loc : Iir) + return Iir_Array_Subtype_Definition + is + Res : Iir_Array_Subtype_Definition; + begin + Res := Create_Array_Subtype (Base_Type, Get_Location (Loc)); + Set_Nth_Element (Get_Index_Subtype_List (Res), 0, Index_Type); + Set_Type_Staticness (Res, Min (Get_Type_Staticness (Res), + Get_Type_Staticness (Index_Type))); + Set_Constraint_State (Res, Fully_Constrained); + Set_Index_Constraint_Flag (Res, True); + return Res; + end Create_Unidim_Array_From_Index; + + function Create_Unidim_Array_By_Length + (Base_Type : Iir; Len : Iir_Int64; Loc : Iir) + return Iir_Array_Subtype_Definition + is + Index_Type : constant Iir := Get_Index_Type (Base_Type, 0); + N_Index_Type : Iir; + begin + N_Index_Type := Create_Range_Subtype_By_Length + (Index_Type, Len, Get_Location (Loc)); + return Create_Unidim_Array_From_Index (Base_Type, N_Index_Type, Loc); + end Create_Unidim_Array_By_Length; + + procedure Free_Eval_Static_Expr (Res : Iir; Orig : Iir) is + begin + if Res /= Orig and then Get_Literal_Origin (Res) = Orig then + Free_Iir (Res); + end if; + end Free_Eval_Static_Expr; + + -- Free the result RES of Eval_String_Literal called with ORIG, if created. + procedure Free_Eval_String_Literal (Res : Iir; Orig : Iir) + is + L : Iir_Flist; + begin + if Res /= Orig then + L := Get_Simple_Aggregate_List (Res); + Destroy_Iir_Flist (L); + Free_Iir (Res); + end if; + end Free_Eval_String_Literal; + + function String_Literal8_To_Simple_Aggregate (Str : Iir) return Iir + is + Element_Type : constant Iir := Get_Base_Type + (Get_Element_Subtype (Get_Base_Type (Get_Type (Str)))); + Literal_List : constant Iir_Flist := + Get_Enumeration_Literal_List (Element_Type); + + Len : constant Nat32 := Get_String_Length (Str); + Id : constant String8_Id := Get_String8_Id (Str); + + List : Iir_Flist; + Lit : Iir; + begin + List := Create_Iir_Flist (Natural (Len)); + + for I in 1 .. Len loop + Lit := Get_Nth_Element + (Literal_List, Natural (Str_Table.Element_String8 (Id, I))); + Set_Nth_Element (List, Natural (I - 1), Lit); + end loop; + return Build_Simple_Aggregate (List, Str, Get_Type (Str)); + end String_Literal8_To_Simple_Aggregate; + + -- Return the offset of EXPR in RNG. A result of 0 means the left bound, + -- a result of 1 mean the next element after the left bound. + -- Assume no overflow. + function Eval_Pos_In_Range (Rng : Iir; Expr : Iir) return Iir_Index32 + is + Left_Pos : constant Iir_Int64 := Eval_Pos (Get_Left_Limit (Rng)); + Pos : constant Iir_Int64 := Eval_Pos (Expr); + begin + case Get_Direction (Rng) is + when Iir_To => + return Iir_Index32 (Pos - Left_Pos); + when Iir_Downto => + return Iir_Index32 (Left_Pos - Pos); + end case; + end Eval_Pos_In_Range; + + procedure Build_Array_Choices_Vector + (Vect : out Iir_Array; Choice_Range : Iir; Choices_Chain : Iir) + is + pragma Assert (Vect'First = 0); + pragma Assert (Vect'Length = Eval_Discrete_Range_Length (Choice_Range)); + Assoc : Iir; + Choice : Iir; + Cur_Pos : Natural; + begin + -- Initialize Vect (to correctly handle 'others'). + Vect := (others => Null_Iir); + + Assoc := Choices_Chain; + Cur_Pos := 0; + Choice := Null_Iir; + while Is_Valid (Assoc) loop + if not Get_Same_Alternative_Flag (Assoc) then + Choice := Assoc; + end if; + case Iir_Kinds_Array_Choice (Get_Kind (Assoc)) is + when Iir_Kind_Choice_By_None => + Vect (Cur_Pos) := Choice; + Cur_Pos := Cur_Pos + 1; + when Iir_Kind_Choice_By_Range => + declare + Rng : constant Iir := Get_Choice_Range (Assoc); + Rng_Start : Iir; + Rng_Len : Iir_Int64; + begin + if Get_Direction (Rng) = Get_Direction (Choice_Range) then + Rng_Start := Get_Left_Limit (Rng); + else + Rng_Start := Get_Right_Limit (Rng); + end if; + Cur_Pos := Natural + (Eval_Pos_In_Range (Choice_Range, Rng_Start)); + Rng_Len := Eval_Discrete_Range_Length (Rng); + for I in 1 .. Rng_Len loop + Vect (Cur_Pos) := Choice; + Cur_Pos := Cur_Pos + 1; + end loop; + end; + when Iir_Kind_Choice_By_Expression => + Cur_Pos := Natural + (Eval_Pos_In_Range (Choice_Range, + Get_Choice_Expression (Assoc))); + Vect (Cur_Pos) := Choice; + when Iir_Kind_Choice_By_Others => + for I in Vect'Range loop + if Vect (I) = Null_Iir then + Vect (I) := Choice; + end if; + end loop; + end case; + Assoc := Get_Chain (Assoc); + end loop; + end Build_Array_Choices_Vector; + + function Aggregate_To_Simple_Aggregate (Aggr : Iir) return Iir + is + Aggr_Type : constant Iir := Get_Type (Aggr); + Index_Type : constant Iir := Get_Index_Type (Aggr_Type, 0); + Index_Range : constant Iir := Eval_Static_Range (Index_Type); + Len : constant Iir_Int64 := Eval_Discrete_Range_Length (Index_Range); + Assocs : constant Iir := Get_Association_Choices_Chain (Aggr); + Vect : Iir_Array (0 .. Integer (Len - 1)); + List : Iir_Flist; + Assoc : Iir; + Expr : Iir; + begin + Assoc := Assocs; + while Is_Valid (Assoc) loop + if not Get_Same_Alternative_Flag (Assoc) then + Expr := Get_Associated_Expr (Assoc); + if Get_Kind (Get_Type (Expr)) + in Iir_Kinds_Scalar_Type_And_Subtype_Definition + then + Expr := Eval_Expr_Keep_Orig (Expr, True); + Set_Associated_Expr (Assoc, Expr); + end if; + end if; + Assoc := Get_Chain (Assoc); + end loop; + + Build_Array_Choices_Vector (Vect, Index_Range, Assocs); + + List := Create_Iir_Flist (Natural (Len)); + if Len > 0 then + -- Workaround GNAT GPL2014 compiler bug. + for I in Vect'Range loop + Set_Nth_Element (List, I, Get_Associated_Expr (Vect (I))); + end loop; + end if; + + return Build_Simple_Aggregate (List, Aggr, Aggr_Type); + end Aggregate_To_Simple_Aggregate; + + function Eval_String_Literal (Str : Iir) return Iir is + begin + case Get_Kind (Str) is + when Iir_Kind_String_Literal8 => + return String_Literal8_To_Simple_Aggregate (Str); + + when Iir_Kind_Aggregate => + return Aggregate_To_Simple_Aggregate (Str); + + when Iir_Kind_Simple_Aggregate => + return Str; + + when others => + Error_Kind ("eval_string_literal", Str); + end case; + end Eval_String_Literal; + + function Eval_Monadic_Operator (Orig : Iir; Operand : Iir) return Iir + is + pragma Unsuppress (Overflow_Check); + subtype Iir_Predefined_Vector_Minmax is Iir_Predefined_Functions range + Iir_Predefined_Vector_Minimum .. Iir_Predefined_Vector_Maximum; + + Func : Iir_Predefined_Functions; + begin + if Get_Kind (Operand) = Iir_Kind_Overflow_Literal then + -- Propagate overflow. + return Build_Overflow (Orig); + end if; + + Func := Get_Implicit_Definition (Get_Implementation (Orig)); + case Func is + when Iir_Predefined_Integer_Negation => + return Build_Integer (-Get_Value (Operand), Orig); + when Iir_Predefined_Integer_Identity => + return Build_Integer (Get_Value (Operand), Orig); + when Iir_Predefined_Integer_Absolute => + return Build_Integer (abs Get_Value (Operand), Orig); + + when Iir_Predefined_Floating_Negation => + return Build_Floating (-Get_Fp_Value (Operand), Orig); + when Iir_Predefined_Floating_Identity => + return Build_Floating (Get_Fp_Value (Operand), Orig); + when Iir_Predefined_Floating_Absolute => + return Build_Floating (abs Get_Fp_Value (Operand), Orig); + + when Iir_Predefined_Physical_Negation => + return Build_Physical (-Get_Physical_Value (Operand), Orig); + when Iir_Predefined_Physical_Identity => + return Build_Physical (Get_Physical_Value (Operand), Orig); + when Iir_Predefined_Physical_Absolute => + return Build_Physical (abs Get_Physical_Value (Operand), Orig); + + when Iir_Predefined_Boolean_Not + | Iir_Predefined_Bit_Not => + return Build_Enumeration (Get_Enum_Pos (Operand) = 0, Orig); + + when Iir_Predefined_TF_Array_Not => + declare + Lit_Val : Iir; + O_List : Iir_Flist; + R_List : Iir_Flist; + El : Iir; + Lit : Iir; + begin + Lit_Val := Eval_String_Literal (Operand); + O_List := Get_Simple_Aggregate_List (Lit_Val); + R_List := Create_Iir_Flist (Get_Nbr_Elements (O_List)); + + for I in Flist_First .. Flist_Last (O_List) loop + El := Get_Nth_Element (O_List, I); + case Get_Enum_Pos (El) is + when 0 => + Lit := Bit_1; + when 1 => + Lit := Bit_0; + when others => + raise Internal_Error; + end case; + Set_Nth_Element (R_List, I, Lit); + end loop; + Free_Eval_String_Literal (Lit_Val, Operand); + return Build_Simple_Aggregate + (R_List, Orig, Get_Type (Operand)); + end; + + when Iir_Predefined_Enum_To_String => + return Eval_Enum_To_String (Operand, Orig); + when Iir_Predefined_Integer_To_String => + return Eval_Integer_Image (Get_Value (Operand), Orig); + + when Iir_Predefined_Array_Char_To_String => + -- LRM08 5.7 String representation + -- - For a given value that is of a one-dimensional array type + -- whose element type is a character type that contains only + -- character literals, the string representation has the same + -- length as the given value. Each element of the string + -- representation is the same character literal as the matching + -- element of the given value. + declare + Saggr : Iir; + Lits : Iir_Flist; + El : Iir; + C : Character; + String_Id : String8_Id; + Len : Natural; + begin + Saggr := Eval_String_Literal (Operand); + Lits := Get_Simple_Aggregate_List (Saggr); + Len := Get_Nbr_Elements (Lits); + String_Id := Str_Table.Create_String8; + for I in Flist_First .. Flist_Last (Lits) loop + El := Get_Nth_Element (Lits, I); + C := Get_Character (Get_Identifier (El)); + Str_Table.Append_String8_Char (C); + end loop; + Free_Eval_String_Literal (Saggr, Operand); + + return Build_String (String_Id, Nat32 (Len), Orig); + end; + + when Iir_Predefined_Vector_Minimum + | Iir_Predefined_Vector_Maximum => + -- LRM08 5.3.2.4 Predefined operations on array types + declare + Saggr : Iir; + Lits : Iir_Flist; + Res : Iir; + El : Iir; + Cmp : Compare_Type; + begin + Saggr := Eval_String_Literal (Operand); + Lits := Get_Simple_Aggregate_List (Saggr); + + if Get_Nbr_Elements (Lits) = 0 then + declare + Typ : constant Iir := + Get_Type (Get_Implementation (Orig)); + Rng : constant Iir := Eval_Static_Range (Typ); + begin + case Iir_Predefined_Vector_Minmax (Func) is + when Iir_Predefined_Vector_Minimum => + Res := Get_High_Limit (Rng); + when Iir_Predefined_Vector_Maximum => + Res := Get_Low_Limit (Rng); + end case; + Res := Eval_Static_Expr (Res); + end; + else + Res := Get_Nth_Element (Lits, 0); + for I in Flist_First .. Flist_Last (Lits) loop + El := Get_Nth_Element (Lits, I); + Cmp := Eval_Scalar_Compare (El, Res); + case Iir_Predefined_Vector_Minmax (Func) is + when Iir_Predefined_Vector_Minimum => + if Cmp <= Compare_Eq then + Res := El; + end if; + when Iir_Predefined_Vector_Maximum => + if Cmp >= Compare_Eq then + Res := El; + end if; + end case; + end loop; + end if; + Free_Eval_String_Literal (Saggr, Operand); + return Res; + end; + + when others => + Error_Internal (Orig, "eval_monadic_operator: " & + Iir_Predefined_Functions'Image (Func)); + end case; + exception + when Constraint_Error => + -- Can happen for absolute. + Warning_Msg_Sem (Warnid_Runtime_Error, +Orig, + "arithmetic overflow in static expression"); + return Build_Overflow (Orig); + end Eval_Monadic_Operator; + + function Eval_Dyadic_Bit_Array_Operator + (Expr : Iir; + Left, Right : Iir; + Func : Iir_Predefined_Dyadic_TF_Array_Functions) + return Iir + is + use Str_Table; + L_Str : constant String8_Id := Get_String8_Id (Left); + R_Str : constant String8_Id := Get_String8_Id (Right); + Len : Nat32; + Id : String8_Id; + Res : Iir; + begin + Len := Get_String_Length (Left); + if Len /= Get_String_Length (Right) then + Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, + "length of left and right operands mismatch"); + return Build_Overflow (Expr); + else + Id := Create_String8; + case Func is + when Iir_Predefined_TF_Array_And => + for I in 1 .. Len loop + case Element_String8 (L_Str, I) is + when 0 => + Append_String8 (0); + when 1 => + Append_String8 (Element_String8 (R_Str, I)); + when others => + raise Internal_Error; + end case; + end loop; + when Iir_Predefined_TF_Array_Nand => + for I in 1 .. Len loop + case Element_String8 (L_Str, I) is + when 0 => + Append_String8 (1); + when 1 => + case Element_String8 (R_Str, I) is + when 0 => + Append_String8 (1); + when 1 => + Append_String8 (0); + when others => + raise Internal_Error; + end case; + when others => + raise Internal_Error; + end case; + end loop; + when Iir_Predefined_TF_Array_Or => + for I in 1 .. Len loop + case Element_String8 (L_Str, I) is + when 1 => + Append_String8 (1); + when 0 => + Append_String8 (Element_String8 (R_Str, I)); + when others => + raise Internal_Error; + end case; + end loop; + when Iir_Predefined_TF_Array_Nor => + for I in 1 .. Len loop + case Element_String8 (L_Str, I) is + when 1 => + Append_String8 (0); + when 0 => + case Element_String8 (R_Str, I) is + when 0 => + Append_String8 (1); + when 1 => + Append_String8 (0); + when others => + raise Internal_Error; + end case; + when others => + raise Internal_Error; + end case; + end loop; + when Iir_Predefined_TF_Array_Xor => + for I in 1 .. Len loop + case Element_String8 (L_Str, I) is + when 1 => + case Element_String8 (R_Str, I) is + when 0 => + Append_String8 (1); + when 1 => + Append_String8 (0); + when others => + raise Internal_Error; + end case; + when 0 => + Append_String8 (Element_String8 (R_Str, I)); + when others => + raise Internal_Error; + end case; + end loop; + when others => + Error_Internal (Expr, "eval_dyadic_bit_array_functions: " & + Iir_Predefined_Functions'Image (Func)); + end case; + Res := Build_String (Id, Len, Expr); + + -- The unconstrained type is replaced by the constrained one. + Set_Type (Res, Get_Type (Left)); + return Res; + end if; + end Eval_Dyadic_Bit_Array_Operator; + + -- Return TRUE if VAL /= 0. + function Check_Integer_Division_By_Zero (Expr : Iir; Val : Iir) + return Boolean + is + begin + if Get_Value (Val) = 0 then + Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, "division by 0"); + return False; + else + return True; + end if; + end Check_Integer_Division_By_Zero; + + function Eval_Shift_Operator + (Left, Right : Iir; Origin : Iir; Func : Iir_Predefined_Shift_Functions) + return Iir + is + Count : constant Iir_Int64 := Get_Value (Right); + Arr_List : constant Iir_Flist := Get_Simple_Aggregate_List (Left); + Len : constant Natural := Get_Nbr_Elements (Arr_List); + Cnt : Natural; + Res_List : Iir_Flist; + Dir_Left : Boolean; + E : Iir; + begin + -- LRM93 7.2.3 + -- That is, if R is 0 or if L is a null array, the return value is L. + if Count = 0 or Len = 0 then + return Build_Simple_Aggregate (Arr_List, Origin, Get_Type (Left)); + end if; + case Func is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Rol => + Dir_Left := True; + when Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sra + | Iir_Predefined_Array_Ror => + Dir_Left := False; + end case; + if Count < 0 then + Cnt := Natural (-Count); + Dir_Left := not Dir_Left; + else + Cnt := Natural (Count); + end if; + + case Func is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl => + declare + Enum_List : constant Iir_Flist := + Get_Enumeration_Literal_List + (Get_Base_Type (Get_Element_Subtype (Get_Type (Left)))); + begin + E := Get_Nth_Element (Enum_List, 0); + end; + when Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra => + if Dir_Left then + E := Get_Nth_Element (Arr_List, Len - 1); + else + E := Get_Nth_Element (Arr_List, 0); + end if; + when Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + Cnt := Cnt mod Len; + if not Dir_Left then + Cnt := (Len - Cnt) mod Len; + end if; + end case; + + Res_List := Create_Iir_Flist (Len); + + case Func is + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra => + if Dir_Left then + if Cnt < Len then + for I in Cnt .. Len - 1 loop + Set_Nth_Element + (Res_List, I - Cnt, Get_Nth_Element (Arr_List, I)); + end loop; + else + Cnt := Len; + end if; + for I in 0 .. Cnt - 1 loop + Set_Nth_Element (Res_List, Len - Cnt + I, E); + end loop; + else + if Cnt > Len then + Cnt := Len; + end if; + for I in 0 .. Cnt - 1 loop + Set_Nth_Element (Res_List, I, E); + end loop; + for I in Cnt .. Len - 1 loop + Set_Nth_Element + (Res_List, I, Get_Nth_Element (Arr_List, I - Cnt)); + end loop; + end if; + when Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + for I in 1 .. Len loop + Set_Nth_Element + (Res_List, I - 1, Get_Nth_Element (Arr_List, Cnt)); + Cnt := Cnt + 1; + if Cnt = Len then + Cnt := 0; + end if; + end loop; + end case; + return Build_Simple_Aggregate (Res_List, Origin, Get_Type (Left)); + end Eval_Shift_Operator; + + -- Note: operands must be locally static. + function Eval_Concatenation + (Left, Right : Iir; Orig : Iir; Func : Iir_Predefined_Concat_Functions) + return Iir + is + Res_List : Iir_Flist; + Res_Len : Natural; + Res_Type : Iir; + Origin_Type : Iir; + Left_Aggr, Right_Aggr : Iir; + Left_List, Right_List : Iir_Flist; + Left_Len, Right_Len : Natural; + begin + -- Compute length of the result. + -- Left: + case Func is + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Element_Element_Concat => + Left_Len := 1; + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Array_Array_Concat => + Left_Aggr := Eval_String_Literal (Left); + Left_List := Get_Simple_Aggregate_List (Left_Aggr); + Left_Len := Get_Nbr_Elements (Left_List); + end case; + -- Right: + case Func is + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + Right_Len := 1; + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Array_Array_Concat => + Right_Aggr := Eval_String_Literal (Right); + Right_List := Get_Simple_Aggregate_List (Right_Aggr); + Right_Len := Get_Nbr_Elements (Right_List); + end case; + + Res_Len := Left_Len + Right_Len; + Res_List := Create_Iir_Flist (Res_Len); + -- Do the concatenation. + -- Left: + case Func is + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Element_Element_Concat => + Set_Nth_Element (Res_List, 0, Left); + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Array_Array_Concat => + for I in 0 .. Left_Len - 1 loop + Set_Nth_Element (Res_List, I, Get_Nth_Element (Left_List, I)); + end loop; + Free_Eval_String_Literal (Left_Aggr, Left); + end case; + -- Right: + case Func is + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + Set_Nth_Element (Res_List, Left_Len, Right); + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Array_Array_Concat => + for I in 0 .. Right_Len - 1 loop + Set_Nth_Element + (Res_List, Left_Len + I, Get_Nth_Element (Right_List, I)); + end loop; + Free_Eval_String_Literal (Right_Aggr, Right); + end case; + + -- Compute subtype... + Origin_Type := Get_Type (Orig); + Res_Type := Null_Iir; + if Func = Iir_Predefined_Array_Array_Concat + and then Left_Len = 0 + then + if Flags.Vhdl_Std = Vhdl_87 then + -- LRM87 7.2.3 + -- [...], unless the left operand is a null array, in which case + -- the result of the concatenation is the right operand. + Res_Type := Get_Type (Right); + else + -- LRM93 7.2.4 + -- If both operands are null arrays, then the result of the + -- concatenation is the right operand. + if Get_Nbr_Elements (Right_List) = 0 then + Res_Type := Get_Type (Right); + end if; + end if; + end if; + if Res_Type = Null_Iir then + if Flags.Vhdl_Std = Vhdl_87 + and then (Func = Iir_Predefined_Array_Array_Concat + or Func = Iir_Predefined_Array_Element_Concat) + then + -- LRM87 7.2.3 + -- The left bound of the result is the left operand, [...] + -- + -- LRM87 7.2.3 + -- The direction of the result is the direction of the left + -- operand, [...] + declare + Left_Index : constant Iir := + Get_Index_Type (Get_Type (Left), 0); + Left_Range : constant Iir := + Get_Range_Constraint (Left_Index); + Ret_Type : constant Iir := + Get_Return_Type (Get_Implementation (Orig)); + A_Range : Iir; + Index_Type : Iir; + begin + A_Range := Create_Iir (Iir_Kind_Range_Expression); + Set_Type (A_Range, Get_Index_Type (Ret_Type, 0)); + Set_Expr_Staticness (A_Range, Locally); + Set_Left_Limit (A_Range, Get_Left_Limit (Left_Range)); + Set_Direction (A_Range, Get_Direction (Left_Range)); + Location_Copy (A_Range, Orig); + Set_Right_Limit_By_Length (A_Range, Iir_Int64 (Res_Len)); + Index_Type := Create_Range_Subtype_From_Type + (Left_Index, Get_Location (Orig)); + Set_Range_Constraint (Index_Type, A_Range); + Res_Type := Create_Unidim_Array_From_Index + (Origin_Type, Index_Type, Orig); + end; + else + -- LRM93 7.2.4 + -- Otherwise, the direction and bounds of the result are + -- determined as follows: let S be the index subtype of the base + -- type of the result. The direction of the result of the + -- concatenation is the direction of S, and the left bound of the + -- result is S'LEFT. + Res_Type := Create_Unidim_Array_By_Length + (Origin_Type, Iir_Int64 (Res_Len), Orig); + end if; + end if; + -- FIXME: this is not necessarily a string, it may be an aggregate if + -- element type is not a character type. + return Build_Simple_Aggregate (Res_List, Orig, Res_Type, Res_Type); + end Eval_Concatenation; + + function Eval_Scalar_Compare (Left, Right : Iir) return Compare_Type + is + Ltype : constant Iir := Get_Base_Type (Get_Type (Left)); + begin + pragma Assert + (Get_Kind (Ltype) = Get_Kind (Get_Base_Type (Get_Type (Right)))); + + case Get_Kind (Ltype) is + when Iir_Kind_Enumeration_Type_Definition => + declare + L_Pos : constant Iir_Int32 := Get_Enum_Pos (Left); + R_Pos : constant Iir_Int32 := Get_Enum_Pos (Right); + begin + if L_Pos = R_Pos then + return Compare_Eq; + else + if L_Pos < R_Pos then + return Compare_Lt; + else + return Compare_Gt; + end if; + end if; + end; + when Iir_Kind_Physical_Type_Definition => + declare + L_Val : constant Iir_Int64 := Get_Physical_Value (Left); + R_Val : constant Iir_Int64 := Get_Physical_Value (Right); + begin + if L_Val = R_Val then + return Compare_Eq; + else + if L_Val < R_Val then + return Compare_Lt; + else + return Compare_Gt; + end if; + end if; + end; + when Iir_Kind_Integer_Type_Definition => + declare + L_Val : constant Iir_Int64 := Get_Value (Left); + R_Val : constant Iir_Int64 := Get_Value (Right); + begin + if L_Val = R_Val then + return Compare_Eq; + else + if L_Val < R_Val then + return Compare_Lt; + else + return Compare_Gt; + end if; + end if; + end; + when Iir_Kind_Floating_Type_Definition => + declare + L_Val : constant Iir_Fp64 := Get_Fp_Value (Left); + R_Val : constant Iir_Fp64 := Get_Fp_Value (Right); + begin + if L_Val = R_Val then + return Compare_Eq; + else + if L_Val < R_Val then + return Compare_Lt; + else + return Compare_Gt; + end if; + end if; + end; + when others => + Error_Kind ("eval_scalar_compare", Ltype); + end case; + end Eval_Scalar_Compare; + + function Eval_Array_Compare (Left, Right : Iir) return Compare_Type is + begin + if Get_Kind (Left) = Iir_Kind_String_Literal8 + and then Get_Kind (Right) = Iir_Kind_String_Literal8 + then + -- Common case: both parameters are strings. + declare + L_Id : constant String8_Id := Get_String8_Id (Left); + R_Id : constant String8_Id := Get_String8_Id (Right); + L_Len : constant Int32 := Get_String_Length (Left); + R_Len : constant Int32 := Get_String_Length (Right); + L_El, R_El : Nat8; + P : Nat32; + begin + P := 1; + while P <= L_Len and P <= R_Len loop + L_El := Str_Table.Element_String8 (L_Id, P); + R_El := Str_Table.Element_String8 (R_Id, P); + if L_El /= R_El then + if L_El < R_El then + return Compare_Lt; + else + return Compare_Gt; + end if; + end if; + P := P + 1; + end loop; + if L_Len = R_Len then + return Compare_Eq; + elsif L_Len < R_Len then + return Compare_Lt; + else + return Compare_Gt; + end if; + end; + else + -- General case. + declare + Left_Val, Right_Val : Iir; + R_List, L_List : Iir_Flist; + R_Len, L_Len : Natural; + P : Natural; + Res : Compare_Type; + begin + Left_Val := Eval_String_Literal (Left); + Right_Val := Eval_String_Literal (Right); + + L_List := Get_Simple_Aggregate_List (Left_Val); + R_List := Get_Simple_Aggregate_List (Right_Val); + L_Len := Get_Nbr_Elements (L_List); + R_Len := Get_Nbr_Elements (R_List); + + Res := Compare_Eq; + P := 0; + while P < L_Len and P < R_Len loop + Res := Eval_Scalar_Compare (Get_Nth_Element (L_List, P), + Get_Nth_Element (R_List, P)); + exit when Res /= Compare_Eq; + P := P + 1; + end loop; + if Res = Compare_Eq then + if L_Len < R_Len then + Res := Compare_Lt; + elsif L_Len > R_Len then + Res := Compare_Gt; + end if; + end if; + + Free_Eval_Static_Expr (Left_Val, Left); + Free_Eval_Static_Expr (Right_Val, Right); + + return Res; + end; + end if; + end Eval_Array_Compare; + + -- ORIG is either a dyadic operator or a function call. + function Eval_Dyadic_Operator (Orig : Iir; Imp : Iir; Left, Right : Iir) + return Iir + is + pragma Unsuppress (Overflow_Check); + Func : constant Iir_Predefined_Functions := + Get_Implicit_Definition (Imp); + begin + if Get_Kind (Left) = Iir_Kind_Overflow_Literal + or else Get_Kind (Right) = Iir_Kind_Overflow_Literal + then + return Build_Overflow (Orig); + end if; + + case Func is + when Iir_Predefined_Integer_Plus => + return Build_Integer (Get_Value (Left) + Get_Value (Right), Orig); + when Iir_Predefined_Integer_Minus => + return Build_Integer (Get_Value (Left) - Get_Value (Right), Orig); + when Iir_Predefined_Integer_Mul => + return Build_Integer (Get_Value (Left) * Get_Value (Right), Orig); + when Iir_Predefined_Integer_Div => + if Check_Integer_Division_By_Zero (Orig, Right) then + return Build_Integer + (Get_Value (Left) / Get_Value (Right), Orig); + else + return Build_Overflow (Orig); + end if; + when Iir_Predefined_Integer_Mod => + if Check_Integer_Division_By_Zero (Orig, Right) then + return Build_Integer + (Get_Value (Left) mod Get_Value (Right), Orig); + else + return Build_Overflow (Orig); + end if; + when Iir_Predefined_Integer_Rem => + if Check_Integer_Division_By_Zero (Orig, Right) then + return Build_Integer + (Get_Value (Left) rem Get_Value (Right), Orig); + else + return Build_Overflow (Orig); + end if; + when Iir_Predefined_Integer_Exp => + return Build_Integer + (Get_Value (Left) ** Integer (Get_Value (Right)), Orig); + + when Iir_Predefined_Integer_Equality => + return Build_Boolean (Get_Value (Left) = Get_Value (Right)); + when Iir_Predefined_Integer_Inequality => + return Build_Boolean (Get_Value (Left) /= Get_Value (Right)); + when Iir_Predefined_Integer_Greater_Equal => + return Build_Boolean (Get_Value (Left) >= Get_Value (Right)); + when Iir_Predefined_Integer_Greater => + return Build_Boolean (Get_Value (Left) > Get_Value (Right)); + when Iir_Predefined_Integer_Less_Equal => + return Build_Boolean (Get_Value (Left) <= Get_Value (Right)); + when Iir_Predefined_Integer_Less => + return Build_Boolean (Get_Value (Left) < Get_Value (Right)); + + when Iir_Predefined_Integer_Minimum => + if Get_Value (Left) < Get_Value (Right) then + return Left; + else + return Right; + end if; + when Iir_Predefined_Integer_Maximum => + if Get_Value (Left) > Get_Value (Right) then + return Left; + else + return Right; + end if; + + when Iir_Predefined_Floating_Equality => + return Build_Boolean (Get_Fp_Value (Left) = Get_Fp_Value (Right)); + when Iir_Predefined_Floating_Inequality => + return Build_Boolean (Get_Fp_Value (Left) /= Get_Fp_Value (Right)); + when Iir_Predefined_Floating_Greater => + return Build_Boolean (Get_Fp_Value (Left) > Get_Fp_Value (Right)); + when Iir_Predefined_Floating_Greater_Equal => + return Build_Boolean (Get_Fp_Value (Left) >= Get_Fp_Value (Right)); + when Iir_Predefined_Floating_Less => + return Build_Boolean (Get_Fp_Value (Left) < Get_Fp_Value (Right)); + when Iir_Predefined_Floating_Less_Equal => + return Build_Boolean (Get_Fp_Value (Left) <= Get_Fp_Value (Right)); + + when Iir_Predefined_Floating_Minus => + return Build_Floating + (Get_Fp_Value (Left) - Get_Fp_Value (Right), Orig); + when Iir_Predefined_Floating_Plus => + return Build_Floating + (Get_Fp_Value (Left) + Get_Fp_Value (Right), Orig); + when Iir_Predefined_Floating_Mul => + return Build_Floating + (Get_Fp_Value (Left) * Get_Fp_Value (Right), Orig); + when Iir_Predefined_Floating_Div => + if Get_Fp_Value (Right) = 0.0 then + Warning_Msg_Sem (Warnid_Runtime_Error, +Orig, + "right operand of division is 0"); + return Build_Overflow (Orig); + else + return Build_Floating + (Get_Fp_Value (Left) / Get_Fp_Value (Right), Orig); + end if; + when Iir_Predefined_Floating_Exp => + declare + Exp : Iir_Int64; + Res : Iir_Fp64; + Val : Iir_Fp64; + begin + Res := 1.0; + Val := Get_Fp_Value (Left); + -- LRM08 9.2.8 Misellaneous operators + -- Exponentiation with an integer exponent is equivalent to + -- repeated multiplication of the left operand by itself for + -- a number of times indicated by the absolute value of the + -- exponent and from left to right; [...] + -- GHDL: use the standard power-of-2 approach. This is not + -- strictly equivalent however. + Exp := abs Get_Value (Right); + while Exp /= 0 loop + if Exp mod 2 = 1 then + Res := Res * Val; + end if; + Exp := Exp / 2; + Val := Val * Val; + end loop; + -- LRM08 9.2.8 Misellaneous operators + -- [...] if the exponent is negative then the result is the + -- reciprocal of that [...] + if Get_Value (Right) < 0 then + Res := 1.0 / Res; + end if; + return Build_Floating (Res, Orig); + end; + + when Iir_Predefined_Floating_Minimum => + if Get_Fp_Value (Left) < Get_Fp_Value (Right) then + return Left; + else + return Right; + end if; + when Iir_Predefined_Floating_Maximum => + if Get_Fp_Value (Left) > Get_Fp_Value (Right) then + return Left; + else + return Right; + end if; + + when Iir_Predefined_Physical_Equality => + return Build_Boolean + (Get_Physical_Value (Left) = Get_Physical_Value (Right)); + when Iir_Predefined_Physical_Inequality => + return Build_Boolean + (Get_Physical_Value (Left) /= Get_Physical_Value (Right)); + when Iir_Predefined_Physical_Greater_Equal => + return Build_Boolean + (Get_Physical_Value (Left) >= Get_Physical_Value (Right)); + when Iir_Predefined_Physical_Greater => + return Build_Boolean + (Get_Physical_Value (Left) > Get_Physical_Value (Right)); + when Iir_Predefined_Physical_Less_Equal => + return Build_Boolean + (Get_Physical_Value (Left) <= Get_Physical_Value (Right)); + when Iir_Predefined_Physical_Less => + return Build_Boolean + (Get_Physical_Value (Left) < Get_Physical_Value (Right)); + + when Iir_Predefined_Physical_Physical_Div => + return Build_Integer + (Get_Physical_Value (Left) / Get_Physical_Value (Right), Orig); + when Iir_Predefined_Physical_Integer_Div => + return Build_Physical + (Get_Physical_Value (Left) / Get_Value (Right), Orig); + when Iir_Predefined_Physical_Minus => + return Build_Physical + (Get_Physical_Value (Left) - Get_Physical_Value (Right), Orig); + when Iir_Predefined_Physical_Plus => + return Build_Physical + (Get_Physical_Value (Left) + Get_Physical_Value (Right), Orig); + when Iir_Predefined_Integer_Physical_Mul => + return Build_Physical + (Get_Value (Left) * Get_Physical_Value (Right), Orig); + when Iir_Predefined_Physical_Integer_Mul => + return Build_Physical + (Get_Physical_Value (Left) * Get_Value (Right), Orig); + when Iir_Predefined_Real_Physical_Mul => + -- FIXME: overflow?? + return Build_Physical + (Iir_Int64 (Get_Fp_Value (Left) + * Iir_Fp64 (Get_Physical_Value (Right))), Orig); + when Iir_Predefined_Physical_Real_Mul => + -- FIXME: overflow?? + return Build_Physical + (Iir_Int64 (Iir_Fp64 (Get_Physical_Value (Left)) + * Get_Fp_Value (Right)), Orig); + when Iir_Predefined_Physical_Real_Div => + -- FIXME: overflow?? + return Build_Physical + (Iir_Int64 (Iir_Fp64 (Get_Physical_Value (Left)) + / Get_Fp_Value (Right)), Orig); + + when Iir_Predefined_Physical_Minimum => + return Build_Physical (Iir_Int64'Min (Get_Physical_Value (Left), + Get_Physical_Value (Right)), + Orig); + when Iir_Predefined_Physical_Maximum => + return Build_Physical (Iir_Int64'Max (Get_Physical_Value (Left), + Get_Physical_Value (Right)), + Orig); + + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Array_Array_Concat + | Iir_Predefined_Element_Element_Concat => + return Eval_Concatenation (Left, Right, Orig, Func); + + when Iir_Predefined_Enum_Equality + | Iir_Predefined_Bit_Match_Equality => + return Build_Enumeration + (Get_Enum_Pos (Left) = Get_Enum_Pos (Right), Orig); + when Iir_Predefined_Enum_Inequality + | Iir_Predefined_Bit_Match_Inequality => + return Build_Enumeration + (Get_Enum_Pos (Left) /= Get_Enum_Pos (Right), Orig); + when Iir_Predefined_Enum_Greater_Equal + | Iir_Predefined_Bit_Match_Greater_Equal => + return Build_Enumeration + (Get_Enum_Pos (Left) >= Get_Enum_Pos (Right), Orig); + when Iir_Predefined_Enum_Greater + | Iir_Predefined_Bit_Match_Greater => + return Build_Enumeration + (Get_Enum_Pos (Left) > Get_Enum_Pos (Right), Orig); + when Iir_Predefined_Enum_Less_Equal + | Iir_Predefined_Bit_Match_Less_Equal => + return Build_Enumeration + (Get_Enum_Pos (Left) <= Get_Enum_Pos (Right), Orig); + when Iir_Predefined_Enum_Less + | Iir_Predefined_Bit_Match_Less => + return Build_Enumeration + (Get_Enum_Pos (Left) < Get_Enum_Pos (Right), Orig); + + when Iir_Predefined_Enum_Minimum => + if Get_Enum_Pos (Left) < Get_Enum_Pos (Right) then + return Left; + else + return Right; + end if; + when Iir_Predefined_Enum_Maximum => + if Get_Enum_Pos (Left) > Get_Enum_Pos (Right) then + return Left; + else + return Right; + end if; + + when Iir_Predefined_Boolean_And + | Iir_Predefined_Bit_And => + return Build_Enumeration + (Get_Enum_Pos (Left) = 1 and Get_Enum_Pos (Right) = 1, Orig); + when Iir_Predefined_Boolean_Nand + | Iir_Predefined_Bit_Nand => + return Build_Enumeration + (not (Get_Enum_Pos (Left) = 1 and Get_Enum_Pos (Right) = 1), + Orig); + when Iir_Predefined_Boolean_Or + | Iir_Predefined_Bit_Or => + return Build_Enumeration + (Get_Enum_Pos (Left) = 1 or Get_Enum_Pos (Right) = 1, Orig); + when Iir_Predefined_Boolean_Nor + | Iir_Predefined_Bit_Nor => + return Build_Enumeration + (not (Get_Enum_Pos (Left) = 1 or Get_Enum_Pos (Right) = 1), + Orig); + when Iir_Predefined_Boolean_Xor + | Iir_Predefined_Bit_Xor => + return Build_Enumeration + (Get_Enum_Pos (Left) = 1 xor Get_Enum_Pos (Right) = 1, Orig); + when Iir_Predefined_Boolean_Xnor + | Iir_Predefined_Bit_Xnor => + return Build_Enumeration + (not (Get_Enum_Pos (Left) = 1 xor Get_Enum_Pos (Right) = 1), + Orig); + + when Iir_Predefined_Dyadic_TF_Array_Functions => + -- FIXME: only for bit ? + return Eval_Dyadic_Bit_Array_Operator (Orig, Left, Right, Func); + + when Iir_Predefined_Universal_R_I_Mul => + return Build_Floating + (Get_Fp_Value (Left) * Iir_Fp64 (Get_Value (Right)), Orig); + when Iir_Predefined_Universal_I_R_Mul => + return Build_Floating + (Iir_Fp64 (Get_Value (Left)) * Get_Fp_Value (Right), Orig); + when Iir_Predefined_Universal_R_I_Div => + return Build_Floating + (Get_Fp_Value (Left) / Iir_Fp64 (Get_Value (Right)), Orig); + + when Iir_Predefined_Array_Sll + | Iir_Predefined_Array_Srl + | Iir_Predefined_Array_Sla + | Iir_Predefined_Array_Sra + | Iir_Predefined_Array_Rol + | Iir_Predefined_Array_Ror => + declare + Left_Aggr : Iir; + Res : Iir; + begin + Left_Aggr := Eval_String_Literal (Left); + Res := Eval_Shift_Operator (Left_Aggr, Right, Orig, Func); + Free_Eval_String_Literal (Left_Aggr, Left); + return Res; + end; + + when Iir_Predefined_Array_Equality => + return Build_Boolean + (Eval_Array_Compare (Left, Right) = Compare_Eq); + when Iir_Predefined_Array_Inequality => + return Build_Boolean + (Eval_Array_Compare (Left, Right) /= Compare_Eq); + when Iir_Predefined_Array_Less => + return Build_Boolean + (Eval_Array_Compare (Left, Right) = Compare_Lt); + when Iir_Predefined_Array_Less_Equal => + return Build_Boolean + (Eval_Array_Compare (Left, Right) <= Compare_Eq); + when Iir_Predefined_Array_Greater => + return Build_Boolean + (Eval_Array_Compare (Left, Right) = Compare_Gt); + when Iir_Predefined_Array_Greater_Equal => + return Build_Boolean + (Eval_Array_Compare (Left, Right) >= Compare_Eq); + + when Iir_Predefined_Boolean_Not + | Iir_Predefined_Boolean_Rising_Edge + | Iir_Predefined_Boolean_Falling_Edge + | Iir_Predefined_Bit_Not + | Iir_Predefined_Bit_Rising_Edge + | Iir_Predefined_Bit_Falling_Edge + | Iir_Predefined_Integer_Absolute + | Iir_Predefined_Integer_Identity + | Iir_Predefined_Integer_Negation + | Iir_Predefined_Floating_Absolute + | Iir_Predefined_Floating_Negation + | Iir_Predefined_Floating_Identity + | Iir_Predefined_Physical_Absolute + | Iir_Predefined_Physical_Identity + | Iir_Predefined_Physical_Negation + | Iir_Predefined_Error + | Iir_Predefined_Record_Equality + | Iir_Predefined_Record_Inequality + | Iir_Predefined_Access_Equality + | Iir_Predefined_Access_Inequality + | Iir_Predefined_TF_Array_Not + | Iir_Predefined_Now_Function + | Iir_Predefined_Deallocate + | Iir_Predefined_Write + | Iir_Predefined_Read + | Iir_Predefined_Read_Length + | Iir_Predefined_Flush + | Iir_Predefined_File_Open + | Iir_Predefined_File_Open_Status + | Iir_Predefined_File_Close + | Iir_Predefined_Endfile + | Iir_Predefined_Array_Char_To_String + | Iir_Predefined_Bit_Vector_To_Ostring + | Iir_Predefined_Bit_Vector_To_Hstring => + -- Not binary or never locally static. + Error_Internal (Orig, "eval_dyadic_operator: " & + Iir_Predefined_Functions'Image (Func)); + + when Iir_Predefined_Bit_Condition => + raise Internal_Error; + + when Iir_Predefined_Array_Minimum + | Iir_Predefined_Array_Maximum + | Iir_Predefined_Vector_Minimum + | Iir_Predefined_Vector_Maximum => + raise Internal_Error; + + when Iir_Predefined_Std_Ulogic_Match_Equality + | Iir_Predefined_Std_Ulogic_Match_Inequality + | Iir_Predefined_Std_Ulogic_Match_Less + | Iir_Predefined_Std_Ulogic_Match_Less_Equal + | Iir_Predefined_Std_Ulogic_Match_Greater + | Iir_Predefined_Std_Ulogic_Match_Greater_Equal => + -- TODO + raise Internal_Error; + + when Iir_Predefined_Enum_To_String + | Iir_Predefined_Integer_To_String + | Iir_Predefined_Floating_To_String + | Iir_Predefined_Real_To_String_Digits + | Iir_Predefined_Real_To_String_Format + | Iir_Predefined_Physical_To_String + | Iir_Predefined_Time_To_String_Unit => + -- TODO + raise Internal_Error; + + when Iir_Predefined_TF_Array_Element_And + | Iir_Predefined_TF_Element_Array_And + | Iir_Predefined_TF_Array_Element_Or + | Iir_Predefined_TF_Element_Array_Or + | Iir_Predefined_TF_Array_Element_Nand + | Iir_Predefined_TF_Element_Array_Nand + | Iir_Predefined_TF_Array_Element_Nor + | Iir_Predefined_TF_Element_Array_Nor + | Iir_Predefined_TF_Array_Element_Xor + | Iir_Predefined_TF_Element_Array_Xor + | Iir_Predefined_TF_Array_Element_Xnor + | Iir_Predefined_TF_Element_Array_Xnor => + -- TODO + raise Internal_Error; + + when Iir_Predefined_TF_Reduction_And + | Iir_Predefined_TF_Reduction_Or + | Iir_Predefined_TF_Reduction_Nand + | Iir_Predefined_TF_Reduction_Nor + | Iir_Predefined_TF_Reduction_Xor + | Iir_Predefined_TF_Reduction_Xnor + | Iir_Predefined_TF_Reduction_Not => + -- TODO + raise Internal_Error; + + when Iir_Predefined_Bit_Array_Match_Equality + | Iir_Predefined_Bit_Array_Match_Inequality + | Iir_Predefined_Std_Ulogic_Array_Match_Equality + | Iir_Predefined_Std_Ulogic_Array_Match_Inequality => + -- TODO + raise Internal_Error; + + when Iir_Predefined_Explicit => + raise Internal_Error; + end case; + exception + when Constraint_Error => + Warning_Msg_Sem (Warnid_Runtime_Error, +Orig, + "arithmetic overflow in static expression"); + return Build_Overflow (Orig); + end Eval_Dyadic_Operator; + + -- Get the parameter of an attribute, or 1 if doesn't exist. + function Eval_Attribute_Parameter_Or_1 (Attr : Iir) return Natural + is + Parameter : constant Iir := Get_Parameter (Attr); + begin + if Is_Null (Parameter) or else Is_Error (Parameter) then + return 1; + else + return Natural (Get_Value (Parameter)); + end if; + end Eval_Attribute_Parameter_Or_1; + + -- Evaluate any array attribute, return the type for the prefix. + function Eval_Array_Attribute (Attr : Iir) return Iir + is + Prefix : Iir; + Prefix_Type : Iir; + Dim : Natural; + begin + Prefix := Get_Prefix (Attr); + case Get_Kind (Prefix) is + when Iir_Kinds_Object_Declaration -- FIXME: remove + | Iir_Kind_Selected_Element + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Implicit_Dereference + | Iir_Kind_Function_Call + | Iir_Kind_Attribute_Value + | Iir_Kind_Attribute_Name + | Iir_Kind_Subtype_Attribute => + Prefix_Type := Get_Type (Prefix); + when Iir_Kinds_Subtype_Definition => + Prefix_Type := Prefix; + when Iir_Kinds_Denoting_Name => + Prefix_Type := Get_Type (Prefix); + when others => + Error_Kind ("eval_array_attribute", Prefix); + end case; + if Get_Kind (Prefix_Type) /= Iir_Kind_Array_Subtype_Definition then + Error_Kind ("eval_array_attribute(2)", Prefix_Type); + end if; + + Dim := Eval_Attribute_Parameter_Or_1 (Attr); + return Get_Nth_Element (Get_Index_Subtype_List (Prefix_Type), Dim - 1); + end Eval_Array_Attribute; + + function Eval_Integer_Image (Val : Iir_Int64; Orig : Iir) return Iir + is + use Str_Table; + Img : String (1 .. 24); -- 23 is enough, 24 is rounded. + L : Natural; + V : Iir_Int64; + Id : String8_Id; + begin + V := Val; + L := Img'Last; + loop + Img (L) := Character'Val (Character'Pos ('0') + abs (V rem 10)); + V := V / 10; + L := L - 1; + exit when V = 0; + end loop; + if Val < 0 then + Img (L) := '-'; + L := L - 1; + end if; + Id := Create_String8; + for I in L + 1 .. Img'Last loop + Append_String8_Char (Img (I)); + end loop; + return Build_String (Id, Nat32 (Img'Last - L), Orig); + end Eval_Integer_Image; + + function Eval_Floating_Image (Val : Iir_Fp64; Orig : Iir) return Iir + is + use Str_Table; + Id : String8_Id; + + -- Sign (1) + digit (1) + dot (1) + digits (15) + 'e' (1) + sign (1) + -- + exp_digits (4) -> 24. + Str : String (1 .. 25); + P : Natural; + + Res : Iir; + begin + P := Str'First; + + Grt.Fcvt.Format_Image (Str, P, Interfaces.IEEE_Float_64 (Val)); + + Id := Create_String8; + for I in 1 .. P loop + Append_String8_Char (Str (I)); + end loop; + Res := Build_String (Id, Int32 (P), Orig); + -- FIXME: this is not correct since the type is *not* constrained. + Set_Type (Res, Create_Unidim_Array_By_Length + (Get_Type (Orig), Iir_Int64 (P), Orig)); + return Res; + end Eval_Floating_Image; + + function Eval_Enumeration_Image (Lit : Iir; Orig : Iir) return Iir + is + use Str_Table; + Name : constant String := Image_Identifier (Lit); + Image_Id : constant String8_Id := Str_Table.Create_String8; + begin + Append_String8_String (Name); + return Build_String (Image_Id, Name'Length, Orig); + end Eval_Enumeration_Image; + + function Build_Enumeration_Value (Val : String; Enum, Expr : Iir) return Iir + is + List : constant Iir_Flist := Get_Enumeration_Literal_List (Enum); + Value : String (Val'range); + Id : Name_Id; + Res : Iir; + begin + if Val'Length = 3 + and then Val (Val'First) = ''' and then Val (Val'Last) = ''' + then + -- A single character. + Id := Get_Identifier (Val (Val'First + 1)); + else + for I in Val'range loop + Value (I) := Ada.Characters.Handling.To_Lower (Val (I)); + end loop; + Id := Get_Identifier (Value); + end if; + Res := Find_Name_In_Flist (List, Id); + if Res /= Null_Iir then + return Build_Constant (Res, Expr); + else + Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, + "value %i not in enumeration %n", (+Id, +Enum)); + return Build_Overflow (Expr); + end if; + end Build_Enumeration_Value; + + function Eval_Physical_Image (Phys, Expr: Iir) return Iir + is + -- Reduces to the base unit (e.g. femtoseconds). + Value : constant String := Iir_Int64'Image (Get_Physical_Value (Phys)); + Unit : constant Iir := + Get_Primary_Unit (Get_Base_Type (Get_Type (Phys))); + UnitName : constant String := Image_Identifier (Unit); + Image_Id : constant String8_Id := Str_Table.Create_String8; + Length : Nat32 := Value'Length + UnitName'Length + 1; + begin + for I in Value'range loop + -- Suppress the Ada +ve integer'image leading space + if I > Value'first or else Value (I) /= ' ' then + Str_Table.Append_String8_Char (Value (I)); + else + Length := Length - 1; + end if; + end loop; + Str_Table.Append_String8_Char (' '); + for I in UnitName'range loop + Str_Table.Append_String8_Char (UnitName (I)); + end loop; + + return Build_String (Image_Id, Length, Expr); + end Eval_Physical_Image; + + function Build_Physical_Value (Val: String; Phys_Type, Expr: Iir) return Iir + is + UnitName : String (Val'range); + Mult : Iir_Int64; + Sep : Natural; + Found_Unit : Boolean := false; + Found_Real : Boolean := false; + Unit : Iir; + begin + -- Separate string into numeric value and make lowercase unit. + for I in reverse Val'range loop + UnitName (I) := Ada.Characters.Handling.To_Lower (Val (I)); + if Vhdl.Scanner.Is_Whitespace (Val (I)) and Found_Unit then + Sep := I; + exit; + else + Found_Unit := true; + end if; + end loop; + + -- Unit name is UnitName(Sep+1..Unit'Last) + for I in Val'First .. Sep loop + if Val (I) = '.' then + Found_Real := true; + end if; + end loop; + + -- Chain down the units looking for matching one + Unit := Get_Primary_Unit (Phys_Type); + while Unit /= Null_Iir loop + exit when (UnitName (Sep + 1 .. UnitName'Last) + = Image_Identifier (Unit)); + Unit := Get_Chain (Unit); + end loop; + if Unit = Null_Iir then + Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, + "Unit """ & UnitName (Sep + 1 .. UnitName'Last) + & """ not in physical type"); + return Build_Overflow (Expr); + end if; + + Mult := Get_Value (Get_Physical_Literal (Unit)); + if Found_Real then + return Build_Physical + (Iir_Int64 (Iir_Fp64'Value (Val (Val'First .. Sep)) + * Iir_Fp64 (Mult)), + Expr); + else + return Build_Physical + (Iir_Int64'Value (Val (Val'First .. Sep)) * Mult, Expr); + end if; + end Build_Physical_Value; + + function Eval_Enum_To_String (Lit : Iir; Orig : Iir) return Iir + is + use Str_Table; + Id : constant Name_Id := Get_Identifier (Lit); + Image_Id : constant String8_Id := Str_Table.Create_String8; + Len : Natural; + begin + if Get_Base_Type (Get_Type (Lit)) = Character_Type_Definition then + -- LRM08 5.7 String representations + -- - For a given value of type CHARACTER, the string representation + -- contains one element that is the given value. + Append_String8 (Nat8 (Get_Enum_Pos (Lit))); + Len := 1; + elsif Is_Character (Id) then + -- LRM08 5.7 String representations + -- - For a given value of an enumeration type other than CHARACTER, + -- if the value is a character literal, the string representation + -- contains a single element that is the character literal; [...] + Append_String8_Char (Get_Character (Id)); + Len := 1; + else + -- LRM08 5.7 String representations + -- - [...] otherwise, the string representation is the sequence of + -- characters in the identifier that is the given value. + declare + Img : constant String := Image (Id); + begin + if Img (Img'First) /= '\' then + Append_String8_String (Img); + Len := Img'Length; + else + declare + Skip : Boolean; + C : Character; + begin + Len := 0; + Skip := False; + for I in Img'First + 1 .. Img'Last - 1 loop + if Skip then + Skip := False; + else + C := Img (I); + Append_String8_Char (C); + Skip := C = '\'; + Len := Len + 1; + end if; + end loop; + end; + end if; + end; + end if; + return Build_String (Image_Id, Nat32 (Len), Orig); + end Eval_Enum_To_String; + + function Eval_Incdec (Expr : Iir; N : Iir_Int64; Origin : Iir) return Iir + is + P : Iir_Int64; + begin + case Get_Kind (Expr) is + when Iir_Kind_Integer_Literal => + return Build_Integer (Get_Value (Expr) + N, Origin); + when Iir_Kind_Enumeration_Literal => + P := Iir_Int64 (Get_Enum_Pos (Expr)) + N; + if P < 0 + or else (P >= Iir_Int64 + (Get_Nbr_Elements + (Get_Enumeration_Literal_List + (Get_Base_Type (Get_Type (Expr)))))) + then + Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, + "static constant violates bounds"); + return Build_Overflow (Origin); + else + return Build_Enumeration (Iir_Index32 (P), Origin); + end if; + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Unit_Declaration => + return Build_Physical (Get_Physical_Value (Expr) + N, Origin); + when others => + Error_Kind ("eval_incdec", Expr); + end case; + end Eval_Incdec; + + function Convert_Range (Rng : Iir; Res_Type : Iir; Loc : Iir) return Iir + is + Res_Btype : Iir; + + function Create_Bound (Val : Iir) return Iir + is + R : Iir; + begin + R := Create_Iir (Iir_Kind_Integer_Literal); + Location_Copy (R, Loc); + Set_Value (R, Get_Value (Val)); + Set_Type (R, Res_Btype); + Set_Expr_Staticness (R, Locally); + return R; + end Create_Bound; + + Res : Iir; + Lit : Iir; + begin + Res_Btype := Get_Base_Type (Res_Type); + Res := Create_Iir (Iir_Kind_Range_Expression); + Location_Copy (Res, Loc); + Set_Type (Res, Res_Btype); + Lit := Create_Bound (Get_Left_Limit (Rng)); + Set_Left_Limit (Res, Lit); + Set_Left_Limit_Expr (Res, Lit); + Lit := Create_Bound (Get_Right_Limit (Rng)); + Set_Right_Limit (Res, Lit); + Set_Right_Limit_Expr (Res, Lit); + Set_Direction (Res, Get_Direction (Rng)); + Set_Expr_Staticness (Res, Locally); + return Res; + end Convert_Range; + + function Eval_Array_Type_Conversion (Conv : Iir; Val : Iir) return Iir + is + Conv_Type : constant Iir := Get_Type (Conv); + Val_Type : constant Iir := Get_Type (Val); + Conv_Index_Type : constant Iir := Get_Index_Type (Conv_Type, 0); + Val_Index_Type : constant Iir := Get_Index_Type (Val_Type, 0); + Index_Type : Iir; + Res_Type : Iir; + Res : Iir; + Rng : Iir; + begin + -- The expression is either a simple aggregate or a (bit) string. + Res := Build_Constant (Val, Conv); + if Get_Constraint_State (Conv_Type) = Fully_Constrained then + Set_Type (Res, Conv_Type); + if not Eval_Is_In_Bound (Val, Conv_Type) then + Warning_Msg_Sem (Warnid_Runtime_Error, +Conv, + "non matching length in type conversion"); + return Build_Overflow (Conv); + end if; + return Res; + else + if Get_Base_Type (Conv_Index_Type) = Get_Base_Type (Val_Index_Type) + then + Index_Type := Val_Index_Type; + else + -- Convert the index range. + -- It is an integer type. + Rng := Convert_Range (Get_Range_Constraint (Val_Index_Type), + Conv_Index_Type, Conv); + Index_Type := Create_Iir (Iir_Kind_Integer_Subtype_Definition); + Location_Copy (Index_Type, Conv); + Set_Range_Constraint (Index_Type, Rng); + Set_Base_Type (Index_Type, Get_Base_Type (Conv_Index_Type)); + Set_Type_Staticness (Index_Type, Locally); + end if; + Res_Type := Create_Unidim_Array_From_Index + (Get_Base_Type (Conv_Type), Index_Type, Conv); + Set_Type (Res, Res_Type); + Set_Type_Conversion_Subtype (Conv, Res_Type); + return Res; + end if; + end Eval_Array_Type_Conversion; + + function Eval_Type_Conversion (Conv : Iir) return Iir + is + Expr : constant Iir := Get_Expression (Conv); + Val : Iir; + Val_Type : Iir; + Conv_Type : Iir; + Res : Iir; + begin + Val := Eval_Static_Expr (Expr); + Val_Type := Get_Base_Type (Get_Type (Val)); + Conv_Type := Get_Base_Type (Get_Type (Conv)); + if Conv_Type = Val_Type then + Res := Build_Constant (Val, Conv); + else + case Get_Kind (Conv_Type) is + when Iir_Kind_Integer_Type_Definition => + case Get_Kind (Val_Type) is + when Iir_Kind_Integer_Type_Definition => + Res := Build_Integer (Get_Value (Val), Conv); + when Iir_Kind_Floating_Type_Definition => + Res := Build_Integer + (Iir_Int64 (Get_Fp_Value (Val)), Conv); + when others => + Error_Kind ("eval_type_conversion(1)", Val_Type); + end case; + when Iir_Kind_Floating_Type_Definition => + case Get_Kind (Val_Type) is + when Iir_Kind_Integer_Type_Definition => + Res := Build_Floating (Iir_Fp64 (Get_Value (Val)), Conv); + when Iir_Kind_Floating_Type_Definition => + Res := Build_Floating (Get_Fp_Value (Val), Conv); + when others => + Error_Kind ("eval_type_conversion(2)", Val_Type); + end case; + when Iir_Kind_Array_Type_Definition => + -- Not a scalar, do not check bounds. + return Eval_Array_Type_Conversion (Conv, Val); + when others => + Error_Kind ("eval_type_conversion(3)", Conv_Type); + end case; + end if; + if not Eval_Is_In_Bound (Res, Get_Type (Conv)) then + if Get_Kind (Res) /= Iir_Kind_Overflow_Literal then + Warning_Msg_Sem (Warnid_Runtime_Error, +Conv, + "result of conversion out of bounds"); + Free_Eval_Static_Expr (Res, Conv); + Res := Build_Overflow (Conv); + end if; + end if; + return Res; + end Eval_Type_Conversion; + + function Eval_Physical_Literal (Expr : Iir) return Iir + is + Val : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kind_Physical_Fp_Literal => + Val := Expr; + when Iir_Kind_Physical_Int_Literal => + -- Create a copy even if the literal has the primary unit. This + -- is required for ownership rule. + Val := Expr; + when Iir_Kind_Unit_Declaration => + Val := Expr; + when Iir_Kinds_Denoting_Name => + Val := Get_Named_Entity (Expr); + pragma Assert (Get_Kind (Val) = Iir_Kind_Unit_Declaration); + when others => + Error_Kind ("eval_physical_literal", Expr); + end case; + return Build_Physical (Get_Physical_Value (Val), Expr); + end Eval_Physical_Literal; + + function Eval_Value_Attribute + (Value : String; Atype : Iir; Orig : Iir) return Iir + is + Base_Type : constant Iir := Get_Base_Type (Atype); + First, Last : Positive; + begin + -- LRM93 14.1 Predefined attributes. + -- Leading and trailing whitespace are ignored. + First := Value'First; + Last := Value'Last; + while First <= Last loop + exit when not Vhdl.Scanner.Is_Whitespace (Value (First)); + First := First + 1; + end loop; + while Last >= First loop + exit when not Vhdl.Scanner.Is_Whitespace (Value (Last)); + Last := Last - 1; + end loop; + + declare + Value1 : String renames Value (First .. Last); + begin + case Get_Kind (Base_Type) is + when Iir_Kind_Integer_Type_Definition => + return Build_Discrete (Iir_Int64'Value (Value1), Orig); + when Iir_Kind_Enumeration_Type_Definition => + return Build_Enumeration_Value (Value1, Base_Type, Orig); + when Iir_Kind_Floating_Type_Definition => + return Build_Floating (Iir_Fp64'value (Value1), Orig); + when Iir_Kind_Physical_Type_Definition => + return Build_Physical_Value (Value1, Base_Type, Orig); + when others => + Error_Kind ("eval_value_attribute", Base_Type); + end case; + end; + end Eval_Value_Attribute; + + -- Be sure that all expressions within an aggregate have been evaluated. + procedure Eval_Aggregate (Aggr : Iir) + is + Assoc : Iir; + Expr : Iir; + begin + Assoc := Get_Association_Choices_Chain (Aggr); + while Is_Valid (Assoc) loop + case Iir_Kinds_Choice (Get_Kind (Assoc)) is + when Iir_Kind_Choice_By_None => + null; + when Iir_Kind_Choice_By_Name => + null; + when Iir_Kind_Choice_By_Range => + Set_Choice_Range + (Assoc, Eval_Range (Get_Choice_Range (Assoc))); + when Iir_Kind_Choice_By_Expression => + Set_Choice_Expression + (Assoc, Eval_Expr (Get_Choice_Expression (Assoc))); + when Iir_Kind_Choice_By_Others => + null; + end case; + if not Get_Same_Alternative_Flag (Assoc) then + Expr := Get_Associated_Expr (Assoc); + end if; + if Get_Kind (Expr) = Iir_Kind_Aggregate then + Eval_Aggregate (Expr); + end if; + Assoc := Get_Chain (Assoc); + end loop; + end Eval_Aggregate; + + function Eval_Selected_Element (Expr : Iir) return Iir + is + Selected_El : constant Iir := Get_Named_Entity (Expr); + El_Pos : constant Iir_Index32 := Get_Element_Position (Selected_El); + Prefix : Iir; + Cur_Pos : Iir_Index32; + Assoc : Iir; + Assoc_Expr : Iir; + Res : Iir; + begin + Prefix := Get_Prefix (Expr); + Prefix := Eval_Static_Expr (Prefix); + if Get_Kind (Prefix) = Iir_Kind_Overflow_Literal then + return Build_Overflow (Expr, Get_Type (Expr)); + end if; + + pragma Assert (Get_Kind (Prefix) = Iir_Kind_Aggregate); + Assoc := Get_Association_Choices_Chain (Prefix); + Cur_Pos := 0; + Assoc_Expr := Null_Iir; + loop + if not Get_Same_Alternative_Flag (Assoc) then + Assoc_Expr := Assoc; + end if; + case Iir_Kinds_Record_Choice (Get_Kind (Assoc)) is + when Iir_Kind_Choice_By_None => + exit when Cur_Pos = El_Pos; + Cur_Pos := Cur_Pos + 1; + when Iir_Kind_Choice_By_Name => + declare + Choice : constant Iir := Get_Choice_Name (Assoc); + begin + exit when Get_Element_Position (Get_Named_Entity (Choice)) + = El_Pos; + end; + when Iir_Kind_Choice_By_Others => + exit; + end case; + Assoc := Get_Chain (Assoc); + end loop; + + -- Eval element and save it. + Res := Eval_Expr_Keep_Orig (Get_Associated_Expr (Assoc_Expr), True); + Set_Associated_Expr (Assoc_Expr, Res); + return Res; + end Eval_Selected_Element; + + function Eval_Indexed_Aggregate (Prefix : Iir; Expr : Iir) return Iir + is + Indexes : constant Iir_Flist := Get_Index_List (Expr); + Prefix_Type : constant Iir := Get_Type (Prefix); + Indexes_Type : constant Iir_Flist := + Get_Index_Subtype_List (Prefix_Type); + Idx : Iir; + Assoc : Iir; + Assoc_Expr : Iir; + Aggr_Bounds : Iir; + Aggr : Iir; + Cur_Pos : Iir_Int64; + Res : Iir; + begin + Aggr := Prefix; + + for Dim in Flist_First .. Flist_Last (Indexes) loop + Idx := Get_Nth_Element (Indexes, Dim); + + -- Find Idx in choices. + Assoc := Get_Association_Choices_Chain (Aggr); + Aggr_Bounds := Eval_Static_Range + (Get_Nth_Element (Indexes_Type, Dim)); + Cur_Pos := Eval_Pos (Eval_Discrete_Range_Left (Aggr_Bounds)); + Assoc_Expr := Null_Iir; + loop + if not Get_Same_Alternative_Flag (Assoc) then + Assoc_Expr := Assoc; + end if; + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + exit when Cur_Pos = Eval_Pos (Idx); + case Get_Direction (Aggr_Bounds) is + when Iir_To => + Cur_Pos := Cur_Pos + 1; + when Iir_Downto => + Cur_Pos := Cur_Pos - 1; + end case; + when Iir_Kind_Choice_By_Expression => + exit when Eval_Is_Eq (Get_Choice_Expression (Assoc), Idx); + when Iir_Kind_Choice_By_Range => + exit when Eval_Is_In_Bound (Idx, Get_Choice_Range (Assoc)); + when Iir_Kind_Choice_By_Others => + exit; + when others => + raise Internal_Error; + end case; + Assoc := Get_Chain (Assoc); + end loop; + Aggr := Get_Associated_Expr (Assoc_Expr); + end loop; + + -- Eval element and save it. + Res := Eval_Expr_Keep_Orig (Aggr, True); + Set_Associated_Expr (Assoc_Expr, Res); + + return Res; + end Eval_Indexed_Aggregate; + + function Eval_Indexed_String_Literal8 (Str : Iir; Expr : Iir) return Iir + is + Str_Type : constant Iir := Get_Type (Str); + + Index_Type : constant Iir := Get_Index_Type (Str_Type, 0); + Index_Range : constant Iir := Eval_Static_Range (Index_Type); + + Indexes : constant Iir_Flist := Get_Index_List (Expr); + + Id : constant String8_Id := Get_String8_Id (Str); + + Idx : Iir; + Pos : Iir_Index32; + begin + Idx := Eval_Static_Expr (Get_Nth_Element (Indexes, 0)); + Pos := Eval_Pos_In_Range (Index_Range, Idx); + + return Build_Enumeration_Constant + (Iir_Index32 (Str_Table.Element_String8 (Id, Int32 (Pos + 1))), Expr); + end Eval_Indexed_String_Literal8; + + function Eval_Indexed_Simple_Aggregate (Aggr : Iir; Expr : Iir) return Iir + is + Aggr_Type : constant Iir := Get_Type (Aggr); + + Index_Type : constant Iir := Get_Index_Type (Aggr_Type, 0); + Index_Range : constant Iir := Eval_Static_Range (Index_Type); + + Indexes : constant Iir_Flist := Get_Index_List (Expr); + + Idx : Iir; + Pos : Iir_Index32; + El : Iir; + begin + Idx := Eval_Static_Expr (Get_Nth_Element (Indexes, 0)); + Set_Nth_Element (Indexes, 0, Idx); + Pos := Eval_Pos_In_Range (Index_Range, Idx); + + El := Get_Nth_Element (Get_Simple_Aggregate_List (Aggr), Natural (Pos)); + return Build_Constant (El, Expr); + end Eval_Indexed_Simple_Aggregate; + + function Eval_Indexed_Name (Expr : Iir) return Iir + is + Prefix : Iir; + begin + Prefix := Get_Prefix (Expr); + Prefix := Eval_Static_Expr (Prefix); + + declare + Prefix_Type : constant Iir := Get_Type (Prefix); + Indexes_Type : constant Iir_Flist := + Get_Index_Subtype_List (Prefix_Type); + Indexes_List : constant Iir_Flist := Get_Index_List (Expr); + Prefix_Index : Iir; + Index : Iir; + begin + for I in Flist_First .. Flist_Last (Indexes_Type) loop + Prefix_Index := Get_Nth_Element (Indexes_Type, I); + + -- Eval index. + Index := Get_Nth_Element (Indexes_List, I); + Index := Eval_Static_Expr (Index); + Set_Nth_Element (Indexes_List, I, Index); + + -- Return overflow if out of range. + if Get_Kind (Index) = Iir_Kind_Overflow_Literal + or else not Eval_Is_In_Bound (Index, Prefix_Index) + then + return Build_Overflow (Expr, Get_Type (Expr)); + end if; + end loop; + end; + + case Get_Kind (Prefix) is + when Iir_Kind_Aggregate => + return Eval_Indexed_Aggregate (Prefix, Expr); + when Iir_Kind_String_Literal8 => + return Eval_Indexed_String_Literal8 (Prefix, Expr); + when Iir_Kind_Simple_Aggregate => + return Eval_Indexed_Simple_Aggregate (Prefix, Expr); + when Iir_Kind_Overflow_Literal => + return Build_Overflow (Expr, Get_Type (Expr)); + when others => + Error_Kind ("eval_indexed_name", Prefix); + end case; + end Eval_Indexed_Name; + + function Eval_Indexed_Aggregate_By_Offset + (Aggr : Iir; Off : Iir_Index32; Dim : Natural := 0) return Iir + is + Prefix_Type : constant Iir := Get_Type (Aggr); + Indexes_Type : constant Iir_Flist := + Get_Index_Subtype_List (Prefix_Type); + Assoc : Iir; + Assoc_Expr : Iir; + Assoc_Len : Iir_Index32; + Aggr_Bounds : Iir; + Cur_Off : Iir_Index32; + Res : Iir; + Left_Pos : Iir_Int64; + Assoc_Pos : Iir_Int64; + begin + Aggr_Bounds := Eval_Static_Range (Get_Nth_Element (Indexes_Type, Dim)); + Left_Pos := Eval_Pos (Eval_Discrete_Range_Left (Aggr_Bounds)); + + Cur_Off := 0; + Assoc := Get_Association_Choices_Chain (Aggr); + Assoc_Expr := Null_Iir; + while Assoc /= Null_Iir loop + if not Get_Same_Alternative_Flag (Assoc) then + Assoc_Expr := Assoc; + end if; + case Get_Kind (Assoc) is + when Iir_Kind_Choice_By_None => + if Get_Element_Type_Flag (Assoc) then + if Off = Cur_Off then + return Get_Associated_Expr (Assoc); + end if; + Assoc_Len := 1; + else + Res := Get_Associated_Expr (Assoc); + Assoc_Len := Iir_Index32 + (Eval_Discrete_Range_Length + (Get_Index_Type (Get_Type (Res), 0))); + if Off >= Cur_Off and then Off < Cur_Off + Assoc_Len then + return Eval_Indexed_Name_By_Offset (Res, Off - Cur_Off); + end if; + end if; + Cur_Off := Cur_Off + Assoc_Len; + when Iir_Kind_Choice_By_Expression => + Assoc_Pos := Eval_Pos (Get_Choice_Expression (Assoc)); + case Get_Direction (Aggr_Bounds) is + when Iir_To => + Cur_Off := Iir_Index32 (Assoc_Pos - Left_Pos); + when Iir_Downto => + Cur_Off := Iir_Index32 (Left_Pos - Assoc_Pos); + end case; + if Cur_Off = Off then + return Get_Associated_Expr (Assoc); + end if; + when Iir_Kind_Choice_By_Range => + declare + Rng : Iir; + Left : Iir_Int64; + Right : Iir_Int64; + Hi, Lo : Iir_Int64; + Lo_Off, Hi_Off : Iir_Index32; + begin + Rng := Eval_Range (Get_Choice_Range (Assoc)); + Set_Choice_Range (Assoc, Rng); + + Left := Eval_Pos (Get_Left_Limit (Rng)); + Right := Eval_Pos (Get_Right_Limit (Rng)); + case Get_Direction (Rng) is + when Iir_To => + Lo := Left; + Hi := Right; + when Iir_Downto => + Lo := Right; + Hi := Left; + end case; + case Get_Direction (Aggr_Bounds) is + when Iir_To => + Lo_Off := Iir_Index32 (Lo - Left_Pos); + Hi_Off := Iir_Index32 (Hi - Left_Pos); + when Iir_Downto => + Lo_Off := Iir_Index32 (Left_Pos - Lo); + Hi_Off := Iir_Index32 (Left_Pos - Hi); + end case; + if Off >= Lo_Off and then Off <= Hi_Off then + Res := Get_Associated_Expr (Assoc); + if Get_Element_Type_Flag (Assoc) then + return Res; + else + return Eval_Indexed_Name_By_Offset + (Res, Off - Lo_Off); + end if; + end if; + end; + when Iir_Kind_Choice_By_Others => + return Get_Associated_Expr (Assoc_Expr); + when others => + raise Internal_Error; + end case; + Assoc := Get_Chain (Assoc); + end loop; + raise Internal_Error; + end Eval_Indexed_Aggregate_By_Offset; + + function Eval_Indexed_Name_By_Offset (Prefix : Iir; Off : Iir_Index32) + return Iir + is + begin + case Get_Kind (Prefix) is + when Iir_Kind_Aggregate => + return Eval_Indexed_Aggregate_By_Offset (Prefix, Off); + when Iir_Kind_String_Literal8 => + declare + Id : constant String8_Id := Get_String8_Id (Prefix); + El_Type : constant Iir := + Get_Element_Subtype (Get_Type (Prefix)); + Enums : constant Iir_Flist := + Get_Enumeration_Literal_List (El_Type); + Lit : Pos32; + begin + Lit := Str_Table.Element_String8 (Id, Int32 (Off + 1)); + return Get_Nth_Element (Enums, Natural (Lit)); + end; + when Iir_Kind_Simple_Aggregate => + return Get_Nth_Element (Get_Simple_Aggregate_List (Prefix), + Natural (Off)); + when others => + Error_Kind ("eval_indexed_name_by_offset", Prefix); + end case; + end Eval_Indexed_Name_By_Offset; + + function Eval_Static_Expr (Expr: Iir) return Iir + is + Res : Iir; + Val : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kinds_Denoting_Name => + return Eval_Static_Expr (Get_Named_Entity (Expr)); + + when Iir_Kind_Integer_Literal + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Floating_Point_Literal + | Iir_Kind_String_Literal8 + | Iir_Kind_Overflow_Literal + | Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal => + return Expr; + when Iir_Kind_Constant_Declaration => + Val := Eval_Static_Expr (Get_Default_Value (Expr)); + -- Type of the expression should be type of the constant + -- declaration at least in case of array subtype. + -- If the constant is declared as an unconstrained array, get type + -- from the default value. + -- FIXME: handle this during semantisation of the declaration: + -- add an implicit subtype conversion node ? + -- FIXME: this currently creates a node at each evalation. + if Get_Kind (Get_Type (Val)) = Iir_Kind_Array_Type_Definition then + Res := Build_Constant (Val, Expr); + Set_Type (Res, Get_Type (Val)); + return Res; + else + return Val; + end if; + when Iir_Kind_Object_Alias_Declaration => + return Eval_Static_Expr (Get_Name (Expr)); + when Iir_Kind_Unit_Declaration => + return Get_Physical_Literal (Expr); + when Iir_Kind_Simple_Aggregate => + return Expr; + when Iir_Kind_Aggregate => + Eval_Aggregate (Expr); + return Expr; + + when Iir_Kind_Selected_Element => + return Eval_Selected_Element (Expr); + when Iir_Kind_Indexed_Name => + return Eval_Indexed_Name (Expr); + + when Iir_Kind_Parenthesis_Expression => + return Eval_Static_Expr (Get_Expression (Expr)); + when Iir_Kind_Qualified_Expression => + return Eval_Static_Expr (Get_Expression (Expr)); + when Iir_Kind_Type_Conversion => + return Eval_Type_Conversion (Expr); + + when Iir_Kinds_Monadic_Operator => + declare + Operand : Iir; + begin + Operand := Eval_Static_Expr (Get_Operand (Expr)); + return Eval_Monadic_Operator (Expr, Operand); + end; + when Iir_Kinds_Dyadic_Operator => + declare + Left : constant Iir := Get_Left (Expr); + Right : constant Iir := Get_Right (Expr); + Left_Val, Right_Val : Iir; + Res : Iir; + begin + Left_Val := Eval_Static_Expr (Left); + Right_Val := Eval_Static_Expr (Right); + + Res := Eval_Dyadic_Operator + (Expr, Get_Implementation (Expr), Left_Val, Right_Val); + + Free_Eval_Static_Expr (Left_Val, Left); + Free_Eval_Static_Expr (Right_Val, Right); + + return Res; + end; + + when Iir_Kind_Attribute_Name => + -- An attribute name designates an attribute value. + declare + Attr_Expr : constant Iir := + Get_Attribute_Name_Expression (Expr); + Val : Iir; + begin + Val := Eval_Static_Expr (Attr_Expr); + -- FIXME: see constant_declaration. + -- Currently, this avoids weird nodes, such as a string literal + -- whose type is an unconstrained array type. + Res := Build_Constant (Val, Expr); + Set_Type (Res, Get_Type (Val)); + return Res; + end; + + when Iir_Kind_Pos_Attribute => + declare + Param : constant Iir := Get_Parameter (Expr); + Val : Iir; + Res : Iir; + begin + Val := Eval_Static_Expr (Param); + -- FIXME: check bounds, handle overflow. + Res := Build_Integer (Eval_Pos (Val), Expr); + Free_Eval_Static_Expr (Val, Param); + return Res; + end; + when Iir_Kind_Val_Attribute => + declare + Expr_Type : constant Iir := Get_Type (Expr); + Val_Expr : Iir; + Val : Iir_Int64; + begin + Val_Expr := Eval_Static_Expr (Get_Parameter (Expr)); + Val := Eval_Pos (Val_Expr); + -- Note: the type of 'val is a base type. + -- FIXME: handle VHDL93 restrictions. + if Get_Kind (Expr_Type) = Iir_Kind_Enumeration_Type_Definition + and then + not Eval_Int_In_Range (Val, Get_Range_Constraint (Expr_Type)) + then + Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, + "static argument out of the type range"); + return Build_Overflow (Expr); + end if; + if Get_Kind (Get_Base_Type (Get_Type (Expr))) + = Iir_Kind_Physical_Type_Definition + then + return Build_Physical (Val, Expr); + else + return Build_Discrete (Val, Expr); + end if; + end; + when Iir_Kind_Image_Attribute => + declare + Param : Iir; + Param_Type : Iir; + begin + Param := Get_Parameter (Expr); + Param := Eval_Static_Expr (Param); + Eval_Check_Bound (Param, Get_Type (Get_Prefix (Expr))); + Set_Parameter (Expr, Param); + + -- Special case for overflow. + if Get_Kind (Param) = Iir_Kind_Overflow_Literal then + return Build_Overflow (Expr); + end if; + + Param_Type := Get_Base_Type (Get_Type (Param)); + case Get_Kind (Param_Type) is + when Iir_Kind_Integer_Type_Definition => + return Eval_Integer_Image (Get_Value (Param), Expr); + when Iir_Kind_Floating_Type_Definition => + return Eval_Floating_Image (Get_Fp_Value (Param), Expr); + when Iir_Kind_Enumeration_Type_Definition => + return Eval_Enumeration_Image (Param, Expr); + when Iir_Kind_Physical_Type_Definition => + return Eval_Physical_Image (Param, Expr); + when others => + Error_Kind ("eval_static_expr('image)", Param); + end case; + end; + when Iir_Kind_Value_Attribute => + declare + Param : Iir; + begin + Param := Get_Parameter (Expr); + Param := Eval_Static_Expr (Param); + Set_Parameter (Expr, Param); + if Get_Kind (Param) /= Iir_Kind_String_Literal8 then + -- FIXME: Isn't it an implementation restriction. + Warning_Msg_Sem (Warnid_Runtime_Error, +Expr, + "'value argument not a string"); + return Build_Overflow (Expr); + else + return Eval_Value_Attribute + (Image_String_Lit (Param), Get_Type (Expr), Expr); + end if; + end; + + when Iir_Kind_Left_Type_Attribute => + return Eval_Static_Expr + (Get_Left_Limit (Eval_Static_Range (Get_Prefix (Expr)))); + when Iir_Kind_Right_Type_Attribute => + return Eval_Static_Expr + (Get_Right_Limit (Eval_Static_Range (Get_Prefix (Expr)))); + when Iir_Kind_High_Type_Attribute => + return Eval_Static_Expr + (Get_High_Limit (Eval_Static_Range (Get_Prefix (Expr)))); + when Iir_Kind_Low_Type_Attribute => + return Eval_Static_Expr + (Get_Low_Limit (Eval_Static_Range (Get_Prefix (Expr)))); + when Iir_Kind_Ascending_Type_Attribute => + return Build_Boolean + (Get_Direction (Eval_Static_Range (Get_Prefix (Expr))) = Iir_To); + + when Iir_Kind_Length_Array_Attribute => + declare + Index : Iir; + begin + Index := Eval_Array_Attribute (Expr); + return Build_Discrete (Eval_Discrete_Type_Length (Index), Expr); + end; + when Iir_Kind_Left_Array_Attribute => + declare + Index : Iir; + begin + Index := Eval_Array_Attribute (Expr); + return Eval_Static_Expr + (Get_Left_Limit (Get_Range_Constraint (Index))); + end; + when Iir_Kind_Right_Array_Attribute => + declare + Index : Iir; + begin + Index := Eval_Array_Attribute (Expr); + return Eval_Static_Expr + (Get_Right_Limit (Get_Range_Constraint (Index))); + end; + when Iir_Kind_Low_Array_Attribute => + declare + Index : Iir; + begin + Index := Eval_Array_Attribute (Expr); + return Eval_Static_Expr + (Get_Low_Limit (Get_Range_Constraint (Index))); + end; + when Iir_Kind_High_Array_Attribute => + declare + Index : Iir; + begin + Index := Eval_Array_Attribute (Expr); + return Eval_Static_Expr + (Get_High_Limit (Get_Range_Constraint (Index))); + end; + when Iir_Kind_Ascending_Array_Attribute => + declare + Index : Iir; + begin + Index := Eval_Array_Attribute (Expr); + return Build_Boolean + (Get_Direction (Get_Range_Constraint (Index)) = Iir_To); + end; + + when Iir_Kind_Pred_Attribute => + Res := Eval_Incdec + (Eval_Static_Expr (Get_Parameter (Expr)), -1, Expr); + Eval_Check_Bound (Res, Get_Type (Get_Prefix (Expr))); + return Res; + when Iir_Kind_Succ_Attribute => + Res := Eval_Incdec + (Eval_Static_Expr (Get_Parameter (Expr)), +1, Expr); + Eval_Check_Bound (Res, Get_Type (Get_Prefix (Expr))); + return Res; + when Iir_Kind_Leftof_Attribute + | Iir_Kind_Rightof_Attribute => + declare + Rng : Iir; + N : Iir_Int64; + Prefix_Type : constant Iir := Get_Type (Get_Prefix (Expr)); + Res : Iir; + begin + Rng := Eval_Static_Range (Prefix_Type); + case Get_Direction (Rng) is + when Iir_To => + N := 1; + when Iir_Downto => + N := -1; + end case; + case Get_Kind (Expr) is + when Iir_Kind_Leftof_Attribute => + N := -N; + when Iir_Kind_Rightof_Attribute => + null; + when others => + raise Internal_Error; + end case; + Res := Eval_Incdec + (Eval_Static_Expr (Get_Parameter (Expr)), N, Expr); + Eval_Check_Bound (Res, Prefix_Type); + return Res; + end; + + when Iir_Kind_Simple_Name_Attribute => + declare + use Str_Table; + Img : constant String := + Image (Get_Simple_Name_Identifier (Expr)); + Id : String8_Id; + begin + Id := Create_String8; + for I in Img'Range loop + Append_String8_Char (Img (I)); + end loop; + return Build_String (Id, Nat32 (Img'Length), Expr); + end; + + when Iir_Kind_Null_Literal => + return Expr; + + when Iir_Kind_Function_Call => + declare + Imp : constant Iir := Get_Implementation (Expr); + Left, Right : Iir; + begin + -- Note: there can't be association by name. + Left := Get_Parameter_Association_Chain (Expr); + Right := Get_Chain (Left); + + Left := Eval_Static_Expr (Get_Actual (Left)); + if Right = Null_Iir then + return Eval_Monadic_Operator (Expr, Left); + else + Right := Eval_Static_Expr (Get_Actual (Right)); + return Eval_Dyadic_Operator (Expr, Imp, Left, Right); + end if; + end; + + when Iir_Kind_Error => + return Expr; + when others => + Error_Kind ("eval_static_expr", Expr); + end case; + end Eval_Static_Expr; + + -- If FORCE is true, always return a literal. + function Eval_Expr_Keep_Orig (Expr : Iir; Force : Boolean) return Iir + is + Res : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kinds_Denoting_Name => + declare + Orig : constant Iir := Get_Named_Entity (Expr); + begin + Res := Eval_Static_Expr (Orig); + if Res /= Orig or else Force then + return Build_Constant (Res, Expr); + else + return Expr; + end if; + end; + when others => + Res := Eval_Static_Expr (Expr); + if Res /= Expr + and then Get_Literal_Origin (Res) /= Expr + then + -- Need to build a constant if the result is a different + -- literal not tied to EXPR. + return Build_Constant (Res, Expr); + else + return Res; + end if; + end case; + end Eval_Expr_Keep_Orig; + + function Eval_Expr (Expr: Iir) return Iir is + begin + if Get_Expr_Staticness (Expr) /= Locally then + Error_Msg_Sem (+Expr, "expression must be locally static"); + return Expr; + else + return Eval_Expr_Keep_Orig (Expr, False); + end if; + end Eval_Expr; + + -- Subroutine of Can_Eval_Composite_Value. Return True iff EXPR is + -- considered as a small composite. + function Is_Small_Composite_Value (Expr : Iir) return Boolean + is + Expr_Type : constant Iir := Get_Type (Expr); + Indexes : Iir_Flist; + Len : Iir_Int64; + begin + -- Consider only arrays. Records are never composite. + if Get_Kind (Expr_Type) /= Iir_Kind_Array_Subtype_Definition then + return False; + end if; + + -- Element must be scalar. + if Get_Kind (Get_Element_Subtype (Expr_Type)) + not in Iir_Kinds_Scalar_Type_And_Subtype_Definition + then + return False; + end if; + + Indexes := Get_Index_Subtype_List (Expr_Type); + + -- Multi-dimensional arrays aren't considered as small. + if Get_Nbr_Elements (Indexes) /= 1 then + return False; + end if; + + Len := Eval_Discrete_Type_Length (Get_Nth_Element (Indexes, 0)); + return Len <= 128; + end Is_Small_Composite_Value; + + function Can_Eval_Composite_Value (Expr : Iir; Top : Boolean := False) + return Boolean; + + -- Return True if EXPR should be evaluated. + function Can_Eval_Value (Expr : Iir; Top : Boolean) return Boolean is + begin + -- Always evaluate scalar values. + if Get_Kind (Get_Type (Expr)) + in Iir_Kinds_Scalar_Type_And_Subtype_Definition + then + return True; + end if; + return Can_Eval_Composite_Value (Expr, Top); + end Can_Eval_Value; + + -- For composite values. + -- Evluating a composite value is a trade-off: it can simplify the + -- generated code if the value is small enough, or it can be a bad idea if + -- the value is very large. It is very easy to create large static + -- composite values (like: bit_vector'(1 to 10**4 => '0')) + function Can_Eval_Composite_Value (Expr : Iir; Top : Boolean := False) + return Boolean + is + -- We are only considering static values. + pragma Assert (Get_Expr_Staticness (Expr) = Locally); + + -- We are only considering composite types. + pragma Assert (Get_Kind (Get_Type (Expr)) + not in Iir_Kinds_Scalar_Type_And_Subtype_Definition); + begin + case Get_Kind (Expr) is + when Iir_Kind_Type_Conversion + | Iir_Kind_Qualified_Expression => + -- Not yet handled. + return False; + when Iir_Kinds_Denoting_Name => + return Can_Eval_Composite_Value (Get_Named_Entity (Expr), Top); + when Iir_Kind_Constant_Declaration => + -- Pass through names only for small values. + if Top or else not Is_Small_Composite_Value (Expr) then + return False; + else + return Can_Eval_Composite_Value (Get_Default_Value (Expr)); + end if; + when Iir_Kind_Attribute_Name => + if Top or else not Is_Small_Composite_Value (Expr) then + return False; + else + return Can_Eval_Composite_Value + (Get_Attribute_Name_Expression (Expr)); + end if; + when Iir_Kinds_Dyadic_Operator => + -- Concatenation can increase the size. + -- Others (rol, ror...) don't. + return Can_Eval_Value (Get_Left (Expr), False) + and then Can_Eval_Value (Get_Right (Expr), False); + when Iir_Kinds_Monadic_Operator => + -- For not. + return Can_Eval_Composite_Value (Get_Operand (Expr)); + when Iir_Kind_Aggregate => + return Is_Small_Composite_Value (Expr); + when Iir_Kinds_Literal + | Iir_Kind_Enumeration_Literal + | Iir_Kind_Simple_Aggregate + | Iir_Kind_Image_Attribute + | Iir_Kind_Simple_Name_Attribute => + return True; + when Iir_Kind_Overflow_Literal => + return True; + when Iir_Kind_Function_Call => + -- Either using post-fixed notation or implicit functions like + -- to_string. + -- Cannot be a user function (won't be locally static). + declare + Assoc : Iir; + Assoc_Expr : Iir; + begin + Assoc := Get_Parameter_Association_Chain (Expr); + while Is_Valid (Assoc) loop + case Iir_Kinds_Association_Element (Get_Kind (Assoc)) is + when Iir_Kind_Association_Element_By_Expression => + Assoc_Expr := Get_Actual (Assoc); + if not Can_Eval_Value (Assoc_Expr, False) then + return False; + end if; + when Iir_Kind_Association_Element_Open => + null; + when Iir_Kind_Association_Element_By_Individual => + return False; + end case; + Assoc := Get_Chain (Assoc); + end loop; + return True; + end; + + when others => + -- Be safe, don't crash on unhandled expression. + -- Error_Kind ("can_eval_composite_value", Expr); + return False; + end case; + end Can_Eval_Composite_Value; + + function Eval_Expr_If_Static (Expr : Iir) return Iir is + begin + if Expr /= Null_Iir and then Get_Expr_Staticness (Expr) = Locally then + -- Evaluate only when there is a positive effect. + if Can_Eval_Value (Expr, True) then + return Eval_Expr_Keep_Orig (Expr, False); + else + return Expr; + end if; + else + return Expr; + end if; + end Eval_Expr_If_Static; + + function Eval_Expr_Check (Expr : Iir; Sub_Type : Iir) return Iir + is + Res : Iir; + begin + Res := Eval_Expr_Keep_Orig (Expr, False); + Eval_Check_Bound (Res, Sub_Type); + return Res; + end Eval_Expr_Check; + + function Eval_Expr_Check_If_Static (Expr : Iir; Atype : Iir) return Iir + is + Res : Iir; + begin + if Expr /= Null_Iir and then Get_Expr_Staticness (Expr) = Locally then + -- Expression is static and can be evaluated. Don't try to + -- evaluate non-scalar expressions, that may create too large data. + if Get_Kind (Atype) in Iir_Kinds_Scalar_Type_And_Subtype_Definition + then + Res := Eval_Expr_Keep_Orig (Expr, False); + else + Res := Expr; + end if; + + if Res /= Null_Iir + and then Get_Type_Staticness (Atype) = Locally + and then Get_Kind (Atype) in Iir_Kinds_Range_Type_Definition + then + -- Check bounds (as this can be done). + -- FIXME: create overflow_expr ? + Eval_Check_Bound (Res, Atype); + end if; + + return Res; + else + return Expr; + end if; + end Eval_Expr_Check_If_Static; + + function Eval_Int_In_Range (Val : Iir_Int64; Bound : Iir) return Boolean is + begin + case Get_Kind (Bound) is + when Iir_Kind_Range_Expression => + case Get_Direction (Bound) is + when Iir_To => + if Val < Eval_Pos (Get_Left_Limit (Bound)) + or else Val > Eval_Pos (Get_Right_Limit (Bound)) + then + return False; + end if; + when Iir_Downto => + if Val > Eval_Pos (Get_Left_Limit (Bound)) + or else Val < Eval_Pos (Get_Right_Limit (Bound)) + then + return False; + end if; + end case; + when others => + Error_Kind ("eval_int_in_range", Bound); + end case; + return True; + end Eval_Int_In_Range; + + function Eval_Phys_In_Range (Val : Iir_Int64; Bound : Iir) return Boolean + is + Left, Right : Iir_Int64; + begin + case Get_Kind (Bound) is + when Iir_Kind_Range_Expression => + case Get_Kind (Get_Type (Get_Left_Limit (Bound))) is + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + Left := Get_Value (Get_Left_Limit (Bound)); + Right := Get_Value (Get_Right_Limit (Bound)); + when Iir_Kind_Physical_Type_Definition + | Iir_Kind_Physical_Subtype_Definition => + Left := Get_Physical_Value (Get_Left_Limit (Bound)); + Right := Get_Physical_Value (Get_Right_Limit (Bound)); + when others => + Error_Kind ("eval_phys_in_range(1)", Get_Type (Bound)); + end case; + case Get_Direction (Bound) is + when Iir_To => + if Val < Left or else Val > Right then + return False; + end if; + when Iir_Downto => + if Val > Left or else Val < Right then + return False; + end if; + end case; + when others => + Error_Kind ("eval_phys_in_range", Bound); + end case; + return True; + end Eval_Phys_In_Range; + + function Eval_Fp_In_Range (Val : Iir_Fp64; Bound : Iir) return Boolean is + begin + case Get_Kind (Bound) is + when Iir_Kind_Range_Expression => + case Get_Direction (Bound) is + when Iir_To => + if Val < Get_Fp_Value (Get_Left_Limit (Bound)) + or else Val > Get_Fp_Value (Get_Right_Limit (Bound)) + then + return False; + end if; + when Iir_Downto => + if Val > Get_Fp_Value (Get_Left_Limit (Bound)) + or else Val < Get_Fp_Value (Get_Right_Limit (Bound)) + then + return False; + end if; + end case; + when others => + Error_Kind ("eval_fp_in_range", Bound); + end case; + return True; + end Eval_Fp_In_Range; + + -- Return FALSE if literal EXPR is not in SUB_TYPE bounds. + function Eval_Is_In_Bound (Expr : Iir; Sub_Type : Iir) return Boolean + is + Type_Range : Iir; + Val : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kind_Simple_Name + | Iir_Kind_Character_Literal + | Iir_Kind_Selected_Name + | Iir_Kind_Parenthesis_Name => + Val := Get_Named_Entity (Expr); + when others => + Val := Expr; + end case; + + case Get_Kind (Val) is + when Iir_Kind_Error => + -- Ignore errors. + return True; + when Iir_Kind_Overflow_Literal => + -- Never within bounds + return False; + when others => + null; + end case; + + case Get_Kind (Sub_Type) is + when Iir_Kind_Integer_Subtype_Definition => + if Get_Expr_Staticness (Val) /= Locally + or else Get_Type_Staticness (Sub_Type) /= Locally + then + return True; + end if; + Type_Range := Get_Range_Constraint (Sub_Type); + return Eval_Int_In_Range (Get_Value (Val), Type_Range); + + when Iir_Kind_Floating_Subtype_Definition => + if Get_Expr_Staticness (Val) /= Locally + or else Get_Type_Staticness (Sub_Type) /= Locally + then + return True; + end if; + Type_Range := Get_Range_Constraint (Sub_Type); + return Eval_Fp_In_Range (Get_Fp_Value (Val), Type_Range); + + when Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition => + if Get_Expr_Staticness (Val) /= Locally + or else Get_Type_Staticness (Sub_Type) /= Locally + then + return True; + end if; + -- A check is required for an enumeration type definition for + -- 'val attribute. + Type_Range := Get_Range_Constraint (Sub_Type); + return Eval_Int_In_Range + (Iir_Int64 (Get_Enum_Pos (Val)), Type_Range); + + when Iir_Kind_Physical_Subtype_Definition => + if Get_Expr_Staticness (Val) /= Locally + or else Get_Type_Staticness (Sub_Type) /= Locally + then + return True; + end if; + Type_Range := Get_Range_Constraint (Sub_Type); + return Eval_Phys_In_Range (Get_Physical_Value (Val), Type_Range); + + when Iir_Kind_Base_Attribute => + if Get_Expr_Staticness (Val) /= Locally + or else Get_Type_Staticness (Sub_Type) /= Locally + then + return True; + end if; + return Eval_Is_In_Bound (Val, Get_Type (Sub_Type)); + + when Iir_Kind_Array_Subtype_Definition => + declare + Val_Type : constant Iir := Get_Type (Val); + begin + if Is_Null (Val_Type) then + -- Punt on errors. + return True; + end if; + + if Get_Constraint_State (Sub_Type) /= Fully_Constrained + or else + Get_Kind (Val_Type) /= Iir_Kind_Array_Subtype_Definition + or else + Get_Constraint_State (Val_Type) /= Fully_Constrained + then + -- Cannot say no. + return True; + end if; + declare + E_Indexes : constant Iir_Flist := + Get_Index_Subtype_List (Val_Type); + T_Indexes : constant Iir_Flist := + Get_Index_Subtype_List (Sub_Type); + E_El : Iir; + T_El : Iir; + begin + for I in Flist_First .. Flist_Last (E_Indexes) loop + E_El := Get_Index_Type (E_Indexes, I); + T_El := Get_Index_Type (T_Indexes, I); + + if Get_Type_Staticness (E_El) = Locally + and then Get_Type_Staticness (T_El) = Locally + and then (Eval_Discrete_Type_Length (E_El) + /= Eval_Discrete_Type_Length (T_El)) + then + return False; + end if; + end loop; + return True; + end; + end; + + when Iir_Kind_Access_Type_Definition + | Iir_Kind_Access_Subtype_Definition => + return True; + + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Record_Type_Definition + | Iir_Kind_Record_Subtype_Definition => + -- FIXME: do it. + return True; + + when Iir_Kind_File_Type_Definition => + return True; + + when Iir_Kind_Integer_Type_Definition + | Iir_Kind_Physical_Type_Definition + | Iir_Kind_Floating_Type_Definition => + return True; + + when Iir_Kind_Interface_Type_Definition + | Iir_Kind_Protected_Type_Declaration => + return True; + + when Iir_Kind_Error => + return True; + + when others => + Error_Kind ("eval_is_in_bound", Sub_Type); + end case; + end Eval_Is_In_Bound; + + procedure Eval_Check_Bound (Expr : Iir; Sub_Type : Iir) is + begin + if Get_Kind (Expr) = Iir_Kind_Overflow_Literal then + -- Nothing to check, and a message was already generated. + return; + end if; + + if not Eval_Is_In_Bound (Expr, Sub_Type) then + Error_Msg_Sem (+Expr, "static expression violates bounds"); + end if; + end Eval_Check_Bound; + + function Eval_Is_Range_In_Bound + (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean) + return Boolean + is + Type_Range : Iir; + Range_Constraint : constant Iir := Eval_Static_Range (A_Range); + begin + Type_Range := Get_Range_Constraint (Sub_Type); + if not Any_Dir + and then Get_Direction (Type_Range) /= Get_Direction (Range_Constraint) + then + return True; + end if; + + case Get_Kind (Sub_Type) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition => + declare + L, R : Iir_Int64; + begin + -- Check for null range. + L := Eval_Pos (Get_Left_Limit (Range_Constraint)); + R := Eval_Pos (Get_Right_Limit (Range_Constraint)); + case Get_Direction (Range_Constraint) is + when Iir_To => + if L > R then + return True; + end if; + when Iir_Downto => + if L < R then + return True; + end if; + end case; + return Eval_Int_In_Range (L, Type_Range) + and then Eval_Int_In_Range (R, Type_Range); + end; + when Iir_Kind_Floating_Subtype_Definition => + declare + L, R : Iir_Fp64; + begin + -- Check for null range. + L := Get_Fp_Value (Get_Left_Limit (Range_Constraint)); + R := Get_Fp_Value (Get_Right_Limit (Range_Constraint)); + case Get_Direction (Range_Constraint) is + when Iir_To => + if L > R then + return True; + end if; + when Iir_Downto => + if L < R then + return True; + end if; + end case; + return Eval_Fp_In_Range (L, Type_Range) + and then Eval_Fp_In_Range (R, Type_Range); + end; + when others => + Error_Kind ("eval_is_range_in_bound", Sub_Type); + end case; + + -- Should check L <= R or L >= R according to direction. + --return Eval_Is_In_Bound (Get_Left_Limit (A_Range), Sub_Type) + -- and then Eval_Is_In_Bound (Get_Right_Limit (A_Range), Sub_Type); + end Eval_Is_Range_In_Bound; + + procedure Eval_Check_Range + (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean) + is + begin + if not Eval_Is_Range_In_Bound (A_Range, Sub_Type, Any_Dir) then + Error_Msg_Sem (+A_Range, "static range violates bounds"); + end if; + end Eval_Check_Range; + + function Eval_Discrete_Range_Length (Constraint : Iir) return Iir_Int64 + is + -- We don't want to deal with very large ranges here. + pragma Suppress (Overflow_Check); + Res : Iir_Int64; + Left, Right : Iir_Int64; + begin + Left := Eval_Pos (Get_Left_Limit (Constraint)); + Right := Eval_Pos (Get_Right_Limit (Constraint)); + case Get_Direction (Constraint) is + when Iir_To => + if Right < Left then + -- Null range. + return 0; + else + Res := Right - Left + 1; + end if; + when Iir_Downto => + if Left < Right then + -- Null range + return 0; + else + Res := Left - Right + 1; + end if; + end case; + return Res; + end Eval_Discrete_Range_Length; + + function Eval_Discrete_Type_Length (Sub_Type : Iir) return Iir_Int64 + is + begin + case Get_Kind (Sub_Type) is + when Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Integer_Subtype_Definition => + return Eval_Discrete_Range_Length + (Get_Range_Constraint (Sub_Type)); + when others => + Error_Kind ("eval_discrete_type_length", Sub_Type); + end case; + end Eval_Discrete_Type_Length; + + function Eval_Pos (Expr : Iir) return Iir_Int64 is + begin + case Get_Kind (Expr) is + when Iir_Kind_Integer_Literal => + return Get_Value (Expr); + when Iir_Kind_Enumeration_Literal => + return Iir_Int64 (Get_Enum_Pos (Expr)); + when Iir_Kind_Physical_Int_Literal + | Iir_Kind_Physical_Fp_Literal + | Iir_Kind_Unit_Declaration => + return Get_Physical_Value (Expr); + when Iir_Kinds_Denoting_Name => + return Eval_Pos (Get_Named_Entity (Expr)); + when others => + Error_Kind ("eval_pos", Expr); + end case; + end Eval_Pos; + + function Eval_Static_Range (Rng : Iir) return Iir + is + Expr : Iir; + Kind : Iir_Kind; + begin + Expr := Rng; + loop + Kind := Get_Kind (Expr); + case Kind is + when Iir_Kind_Range_Expression => + if Get_Expr_Staticness (Expr) /= Locally then + return Null_Iir; + end if; + + -- Normalize the range expression. + declare + Left : Iir; + Right : Iir; + begin + Left := Get_Left_Limit_Expr (Expr); + if Is_Valid (Left) then + Left := Eval_Expr_Keep_Orig (Left, False); + Set_Left_Limit_Expr (Expr, Left); + Set_Left_Limit (Expr, Left); + end if; + Right := Get_Right_Limit_Expr (Expr); + if Is_Valid (Right) then + Right := Eval_Expr_Keep_Orig (Right, False); + Set_Right_Limit_Expr (Expr, Right); + Set_Right_Limit (Expr, Right); + end if; + end; + return Expr; + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Physical_Subtype_Definition => + Expr := Get_Range_Constraint (Expr); + when Iir_Kind_Range_Array_Attribute + | Iir_Kind_Reverse_Range_Array_Attribute => + declare + Indexes_List : Iir_Flist; + Prefix : Iir; + Res : Iir; + Dim : Natural; + begin + Prefix := Get_Prefix (Expr); + if Get_Kind (Prefix) /= Iir_Kind_Array_Subtype_Definition + then + Prefix := Get_Type (Prefix); + end if; + if Get_Kind (Prefix) /= Iir_Kind_Array_Subtype_Definition + then + -- Unconstrained object. + return Null_Iir; + end if; + Indexes_List := Get_Index_Subtype_List (Prefix); + Dim := Eval_Attribute_Parameter_Or_1 (Expr); + if Dim < 1 + or else Dim > Get_Nbr_Elements (Indexes_List) + then + -- Avoid cascaded errors. + Dim := 1; + end if; + Expr := Get_Nth_Element (Indexes_List, Dim - 1); + if Kind = Iir_Kind_Reverse_Range_Array_Attribute then + Expr := Eval_Static_Range (Expr); + + Res := Create_Iir (Iir_Kind_Range_Expression); + Location_Copy (Res, Expr); + Set_Type (Res, Get_Type (Expr)); + case Get_Direction (Expr) is + when Iir_To => + Set_Direction (Res, Iir_Downto); + when Iir_Downto => + Set_Direction (Res, Iir_To); + end case; + Set_Left_Limit (Res, Get_Right_Limit (Expr)); + Set_Right_Limit (Res, Get_Left_Limit (Expr)); + Set_Range_Origin (Res, Rng); + Set_Expr_Staticness (Res, Get_Expr_Staticness (Expr)); + return Res; + end if; + end; + + when Iir_Kind_Subtype_Declaration + | Iir_Kind_Base_Attribute + | Iir_Kind_Subtype_Attribute + | Iir_Kind_Element_Attribute => + Expr := Get_Type (Expr); + when Iir_Kind_Type_Declaration => + Expr := Get_Type_Definition (Expr); + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + Expr := Get_Named_Entity (Expr); + when others => + Error_Kind ("eval_static_range", Expr); + end case; + end loop; + end Eval_Static_Range; + + function Eval_Range (Arange : Iir) return Iir is + Res : Iir; + begin + Res := Eval_Static_Range (Arange); + if Res /= Arange + and then Get_Range_Origin (Res) /= Arange + then + return Build_Constant_Range (Res, Arange); + else + return Res; + end if; + end Eval_Range; + + function Eval_Range_If_Static (Arange : Iir) return Iir is + begin + if Get_Expr_Staticness (Arange) /= Locally then + return Arange; + else + return Eval_Range (Arange); + end if; + end Eval_Range_If_Static; + + -- Return the range constraint of a discrete range. + function Eval_Discrete_Range_Expression (Constraint : Iir) return Iir + is + Res : Iir; + begin + Res := Eval_Static_Range (Constraint); + if Res = Null_Iir then + Error_Kind ("eval_discrete_range_expression", Constraint); + else + return Res; + end if; + end Eval_Discrete_Range_Expression; + + function Eval_Discrete_Range_Left (Constraint : Iir) return Iir + is + Range_Expr : Iir; + begin + Range_Expr := Eval_Discrete_Range_Expression (Constraint); + return Get_Left_Limit (Range_Expr); + end Eval_Discrete_Range_Left; + + function Eval_Is_Eq (L, R : Iir) return Boolean + is + Expr_Type : constant Iir := Get_Type (L); + begin + case Get_Kind (Expr_Type) is + when Iir_Kind_Integer_Subtype_Definition + | Iir_Kind_Integer_Type_Definition + | Iir_Kind_Physical_Subtype_Definition + | Iir_Kind_Physical_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition => + return Eval_Pos (L) = Eval_Pos (R); + when Iir_Kind_Floating_Subtype_Definition + | Iir_Kind_Floating_Type_Definition => + return Get_Fp_Value (L) = Get_Fp_Value (R); + when others => + Error_Kind ("eval_is_eq", Expr_Type); + end case; + end Eval_Is_Eq; + + function Eval_Operator_Symbol_Name (Id : Name_Id) return String is + begin + return '"' & Image (Id) & '"'; + end Eval_Operator_Symbol_Name; + + function Eval_Simple_Name (Id : Name_Id) return String is + begin + -- LRM 14.1 + -- E'SIMPLE_NAME + -- Result: [...] but with apostrophes (in the case of a character + -- literal) + if Is_Character (Id) then + return ''' & Get_Character (Id) & '''; + end if; + case Id is + when Std_Names.Name_Word_Operators + | Std_Names.Name_First_Operator .. Std_Names.Name_Last_Operator => + return Eval_Operator_Symbol_Name (Id); + when Std_Names.Name_Xnor + | Std_Names.Name_Shift_Operators => + if Flags.Vhdl_Std > Vhdl_87 then + return Eval_Operator_Symbol_Name (Id); + end if; + when others => + null; + end case; + return Image (Id); + end Eval_Simple_Name; + + package body String_Utils is + -- Fill Res from EL. This is used to speed up Lt and Eq operations. + function Get_Str_Info (Expr : Iir) return Str_Info is + begin + case Get_Kind (Expr) is + when Iir_Kind_Simple_Aggregate => + declare + List : constant Iir_Flist := + Get_Simple_Aggregate_List (Expr); + begin + return Str_Info'(Is_String => False, + Len => Nat32 (Get_Nbr_Elements (List)), + List => List); + end; + when Iir_Kind_String_Literal8 => + return Str_Info'(Is_String => True, + Len => Get_String_Length (Expr), + Id => Get_String8_Id (Expr)); + when others => + Error_Kind ("string_utils.get_info", Expr); + end case; + end Get_Str_Info; + + -- Return the position of element IDX of STR. + function Get_Pos (Str : Str_Info; Idx : Nat32) return Iir_Int32 + is + S : Iir; + P : Nat32; + begin + case Str.Is_String is + when False => + S := Get_Nth_Element (Str.List, Natural (Idx)); + return Get_Enum_Pos (S); + when True => + P := Str_Table.Element_String8 (Str.Id, Idx + 1); + return Iir_Int32 (P); + end case; + end Get_Pos; + end String_Utils; + + function Compare_String_Literals (L, R : Iir) return Compare_Type + is + use String_Utils; + L_Info : constant Str_Info := Get_Str_Info (L); + R_Info : constant Str_Info := Get_Str_Info (R); + L_Pos, R_Pos : Iir_Int32; + begin + if L_Info.Len /= R_Info.Len then + raise Internal_Error; + end if; + + for I in 0 .. L_Info.Len - 1 loop + L_Pos := Get_Pos (L_Info, I); + R_Pos := Get_Pos (R_Info, I); + if L_Pos /= R_Pos then + if L_Pos < R_Pos then + return Compare_Lt; + else + return Compare_Gt; + end if; + end if; + end loop; + return Compare_Eq; + end Compare_String_Literals; + + function Get_Path_Instance_Name_Suffix (Attr : Iir) + return Path_Instance_Name_Type + is + -- Current path for name attributes. + Path_Str : String_Acc := null; + Path_Maxlen : Natural := 0; + Path_Len : Natural; + Path_Instance : Iir; + + procedure Deallocate is new Ada.Unchecked_Deallocation + (Name => String_Acc, Object => String); + + procedure Path_Reset is + begin + Path_Len := 0; + Path_Instance := Null_Iir; + if Path_Maxlen = 0 then + Path_Maxlen := 256; + Path_Str := new String (1 .. Path_Maxlen); + end if; + end Path_Reset; + + procedure Path_Add (Str : String) + is + N_Len : Natural; + N_Path : String_Acc; + begin + N_Len := Path_Maxlen; + loop + exit when Path_Len + Str'Length <= N_Len; + N_Len := N_Len * 2; + end loop; + if N_Len /= Path_Maxlen then + N_Path := new String (1 .. N_Len); + N_Path (1 .. Path_Len) := Path_Str (1 .. Path_Len); + Deallocate (Path_Str); + Path_Str := N_Path; + Path_Maxlen := N_Len; + end if; + Path_Str (Path_Len + 1 .. Path_Len + Str'Length) := Str; + Path_Len := Path_Len + Str'Length; + end Path_Add; + + procedure Path_Add_Type_Name (Atype : Iir) + is + Adecl : constant Iir := Get_Type_Declarator (Atype); + begin + Path_Add (Image (Get_Identifier (Adecl))); + end Path_Add_Type_Name; + + procedure Path_Add_Signature (Subprg : Iir) + is + Chain : Iir; + begin + Path_Add ("["); + Chain := Get_Interface_Declaration_Chain (Subprg); + while Chain /= Null_Iir loop + Path_Add_Type_Name (Get_Type (Chain)); + Chain := Get_Chain (Chain); + if Chain /= Null_Iir then + Path_Add (","); + end if; + end loop; + + case Get_Kind (Subprg) is + when Iir_Kind_Function_Declaration => + Path_Add (" return "); + Path_Add_Type_Name (Get_Return_Type (Subprg)); + when others => + null; + end case; + Path_Add ("]"); + end Path_Add_Signature; + + procedure Path_Add_Name (N : Iir) + is + Img : constant String := Eval_Simple_Name (Get_Identifier (N)); + begin + if Img (Img'First) /= 'P' then + -- Skip anonymous processes. + Path_Add (Img); + end if; + end Path_Add_Name; + + procedure Path_Add_Element (El : Iir; Is_Instance : Boolean) is + begin + -- LRM 14.1 + -- E'INSTANCE_NAME + -- There is one full path instance element for each component + -- instantiation, block statement, generate statemenent, process + -- statement, or subprogram body in the design hierarchy between + -- the top design entity and the named entity denoted by the + -- prefix. + -- + -- E'PATH_NAME + -- There is one path instance element for each component + -- instantiation, block statement, generate statement, process + -- statement, or subprogram body in the design hierarchy between + -- the root design entity and the named entity denoted by the + -- prefix. + case Get_Kind (El) is + when Iir_Kind_Library_Declaration => + Path_Add (":"); + Path_Add_Name (El); + Path_Add (":"); + when Iir_Kind_Package_Declaration + | Iir_Kind_Package_Body + | Iir_Kind_Package_Instantiation_Declaration => + if Is_Nested_Package (El) then + Path_Add_Element (Get_Parent (El), Is_Instance); + else + Path_Add_Element + (Get_Library (Get_Design_File (Get_Design_Unit (El))), + Is_Instance); + end if; + Path_Add_Name (El); + Path_Add (":"); + when Iir_Kind_Entity_Declaration => + Path_Instance := El; + when Iir_Kind_Architecture_Body => + Path_Instance := El; + when Iir_Kind_Design_Unit => + Path_Add_Element (Get_Library_Unit (El), Is_Instance); + when Iir_Kind_Sensitized_Process_Statement + | Iir_Kind_Process_Statement + | Iir_Kind_Block_Statement + | Iir_Kind_Protected_Type_Body => + Path_Add_Element (Get_Parent (El), Is_Instance); + Path_Add_Name (El); + Path_Add (":"); + when Iir_Kind_Protected_Type_Declaration => + declare + Decl : constant Iir := Get_Type_Declarator (El); + begin + Path_Add_Element (Get_Parent (Decl), Is_Instance); + Path_Add_Name (Decl); + Path_Add (":"); + end; + when Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration => + Path_Add_Element (Get_Parent (El), Is_Instance); + Path_Add_Name (El); + if Flags.Vhdl_Std >= Vhdl_02 then + -- Add signature. + Path_Add_Signature (El); + end if; + Path_Add (":"); + when Iir_Kind_Procedure_Body => + Path_Add_Element (Get_Subprogram_Specification (El), + Is_Instance); + when Iir_Kind_For_Generate_Statement => + Path_Instance := El; + when Iir_Kind_If_Generate_Statement => + Path_Add_Element (Get_Parent (El), Is_Instance); + Path_Add_Name (El); + Path_Add (":"); + when Iir_Kind_Generate_Statement_Body => + declare + Parent : constant Iir := Get_Parent (El); + begin + if Get_Kind (Parent) = Iir_Kind_For_Generate_Statement then + Path_Instance := El; + else + Path_Add_Element (Parent, Is_Instance); + end if; + end; + when Iir_Kinds_Sequential_Statement => + Path_Add_Element (Get_Parent (El), Is_Instance); + when others => + Error_Kind ("path_add_element", El); + end case; + end Path_Add_Element; + + Prefix : constant Iir := Get_Named_Entity (Get_Prefix (Attr)); + Is_Instance : constant Boolean := + Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; + begin + Path_Reset; + + -- LRM 14.1 + -- E'PATH_NAME + -- The local item name in E'PATH_NAME equals E'SIMPLE_NAME, unless + -- E denotes a library, package, subprogram or label. In this + -- latter case, the package based path or instance based path, + -- as appropriate, will not contain a local item name. + -- + -- E'INSTANCE_NAME + -- The local item name in E'INSTANCE_NAME equals E'SIMPLE_NAME, + -- unless E denotes a library, package, subprogram, or label. In + -- this latter case, the package based path or full instance based + -- path, as appropriate, will not contain a local item name. + case Get_Kind (Prefix) is + when Iir_Kind_Constant_Declaration + | Iir_Kind_Interface_Constant_Declaration + | Iir_Kind_Iterator_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_Interface_Variable_Declaration + | Iir_Kind_Signal_Declaration + | Iir_Kind_Interface_Signal_Declaration + | Iir_Kind_File_Declaration + | Iir_Kind_Interface_File_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Subtype_Declaration => + Path_Add_Element (Get_Parent (Prefix), Is_Instance); + Path_Add_Name (Prefix); + when Iir_Kind_Library_Declaration + | Iir_Kinds_Library_Unit + | Iir_Kind_Function_Declaration + | Iir_Kind_Procedure_Declaration + | Iir_Kinds_Concurrent_Statement + | Iir_Kinds_Sequential_Statement => + Path_Add_Element (Prefix, Is_Instance); + when others => + Error_Kind ("get_path_instance_name_suffix", Prefix); + end case; + + declare + Result : constant Path_Instance_Name_Type := + (Len => Path_Len, + Path_Instance => Path_Instance, + Suffix => Path_Str (1 .. Path_Len)); + begin + Deallocate (Path_Str); + return Result; + end; + end Get_Path_Instance_Name_Suffix; + +end Vhdl.Evaluation; diff --git a/src/vhdl/vhdl-evaluation.ads b/src/vhdl/vhdl-evaluation.ads new file mode 100644 index 000000000..12b8c778e --- /dev/null +++ b/src/vhdl/vhdl-evaluation.ads @@ -0,0 +1,218 @@ +-- Evaluation of static expressions. +-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold +-- +-- GHDL is free software; you can redistribute it and/or modify it under +-- the terms of the GNU General Public License as published by the Free +-- Software Foundation; either version 2, or (at your option) any later +-- version. +-- +-- GHDL 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. See the GNU General Public License +-- for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with GHDL; see the file COPYING. If not, write to the Free +-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA +-- 02111-1307, USA. +with Types; use Types; +with Iirs; use Iirs; + +package Vhdl.Evaluation is + + -- Evaluation is about compile-time computation of expressions, such as + -- 2 + 1 --> 3. This is (of course) possible only with locally (and some + -- globally) static expressions. Evaluation is required during semantic + -- analysis at many places (in fact those where locally static expression + -- are required by the language). For example, the type of O'Range (N) + -- depends on N, so we need to evaluate N. + -- + -- The result of evaluation is a literal (integer, enumeration, real, + -- physical), a string or a simple aggregate. For scalar types, the + -- result is therefore normalized (there is only one kind of result), but + -- for array types, the result isn't: in general it will be a string, but + -- it may be a simple aggregate. Strings are preferred (because they are + -- more compact), but aren't possible in some cases. For example, the + -- evaluation of "Text" & NUL cannot be a string. + -- + -- Some functions (like Eval_Static_Expr) simply returns a result (which + -- may be a node of the expression), others returns a result and set the + -- origin (Literal_Origin or Range_Origin) to remember the original + -- expression that was evaluation. The original expression is kept so that + -- it is possible to print the original tree. + + -- Get the value of a physical integer literal or unit. May propagate + -- Constraint_Error. + function Get_Physical_Value (Expr : Iir) return Iir_Int64; + + -- Get the parameter of an attribute, or 1 if doesn't exist. + function Eval_Attribute_Parameter_Or_1 (Attr : Iir) return Natural; + + -- Evaluate the locally static expression EXPR (without checking that EXPR + -- is locally static). Return a literal or an aggregate, without setting + -- the origin, and do not modify EXPR. This can be used only to get the + -- value of an expression, without replacing it. + function Eval_Static_Expr (Expr: Iir) return Iir; + + -- Evaluate (ie compute) expression EXPR. + -- EXPR is required to be a locally static expression, otherwise an error + -- message is generated. + -- The result is a literal with the origin set. + function Eval_Expr (Expr: Iir) return Iir; + + -- Same as Eval_Expr, but if EXPR is not locally static, the result is + -- EXPR. Also, if EXPR is null_iir, then null_iir is returned. + -- The purpose of this function is to evaluate an expression only if it + -- is locally static. + function Eval_Expr_If_Static (Expr : Iir) return Iir; + + -- Evaluate a physical literal and return a normalized literal (using + -- the primary unit as unit). + function Eval_Physical_Literal (Expr : Iir) return Iir; + + -- Return TRUE if literal EXPR is in SUB_TYPE bounds. + function Eval_Is_In_Bound (Expr : Iir; Sub_Type : Iir) return Boolean; + + -- Emit an error if EXPR violates SUB_TYPE bounds. + procedure Eval_Check_Bound (Expr : Iir; Sub_Type : Iir); + + -- Same as Eval_Expr, but a range check with SUB_TYPE is performed after + -- computation. + function Eval_Expr_Check (Expr : Iir; Sub_Type : Iir) return Iir; + + -- Call Eval_Expr_Check only if EXPR is static. + function Eval_Expr_Check_If_Static (Expr : Iir; Atype : Iir) return Iir; + + -- For a locally static range RNG (a range expression, a range attribute + -- or a name that denotes a type or a subtype) returns its corresponding + -- locally static range_expression. The bounds of the results are also + -- literals. + -- Return a range_expression or NULL_IIR for a non locally static range. + function Eval_Static_Range (Rng : Iir) return Iir; + + -- Return a locally static range expression with the origin set for ARANGE. + function Eval_Range (Arange : Iir) return Iir; + + -- If ARANGE is a locally static range, return locally static range + -- expression (with the origin set), else return ARANGE. + function Eval_Range_If_Static (Arange : Iir) return Iir; + + -- Emit an error if A_RANGE is not included in SUB_TYPE. A_RANGE can be + -- a range expression, a range attribute or a name that denotes a discrete + -- type or subtype. A_RANGE must be a locally static range. + procedure Eval_Check_Range (A_Range : Iir; Sub_Type : Iir; + Any_Dir : Boolean); + + -- Return TRUE if A_RANGE is compatible with SUB_TYPE. Compatibility is + -- defined in LRM: + -- + -- LRM08 5.2 Scalar types + -- A range constraint is /compatible/ with a subtype if each bound of the + -- range belongs to the subtype or if the range constraint defines a null + -- range. + function Eval_Is_Range_In_Bound + (A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean) + return Boolean; + + -- Return TRUE iff VAL belongs to BOUND. + function Eval_Int_In_Range (Val : Iir_Int64; Bound : Iir) return Boolean; + + -- Return the length of the discrete range CONSTRAINT. + function Eval_Discrete_Range_Length (Constraint : Iir) return Iir_Int64; + + -- Return the length of SUB_TYPE. + function Eval_Discrete_Type_Length (Sub_Type : Iir) return Iir_Int64; + + -- Get the left bound of a range constraint. + -- Note: the range constraint may be an attribute or a subtype. + function Eval_Discrete_Range_Left (Constraint : Iir) return Iir; + + -- Return the position of EXPR, ie the result of sub_type'pos (EXPR), where + -- sub_type is the type of expr. + -- EXPR must be of a discrete subtype. + function Eval_Pos (Expr : Iir) return Iir_Int64; + + -- Return True iff L and R (scalar literals) are equal. + function Eval_Is_Eq (L, R : Iir) return Boolean; + + -- Replace ORIGIN (an overflow literal) with extreme positive value (if + -- IS_POS is true) or extreme negative value. + function Build_Extreme_Value (Is_Pos : Boolean; Origin : Iir) return Iir; + + -- Create a Iir_Kind_Overflow node of type EXPR_TYPE for ORIGIN. + function Build_Overflow (Origin : Iir; Expr_Type : Iir) return Iir; + + -- Fill VECT with choices from CHOICES_CHAIN: each position of CHOICE_RANGE + -- is associated with its corresponding choice from CHOICES_CHAIN. + -- VECT bounds must be 0 .. Len - 1, where Len is the length of + -- CHOICE_RANGE. + procedure Build_Array_Choices_Vector + (Vect : out Iir_Array; Choice_Range : Iir; Choices_Chain : Iir); + + -- Create an array subtype from LEN and BASE_TYPE, according to rules + -- of LRM93 7.3.2.2. (which are the same as LRM93 7.2.4). + function Create_Unidim_Array_By_Length + (Base_Type : Iir; Len : Iir_Int64; Loc : Iir) + return Iir_Array_Subtype_Definition; + + -- Create a subtype of A_TYPE whose length is LEN. + -- This is used to create subtypes for strings or aggregates. + function Create_Range_Subtype_By_Length + (A_Type : Iir; Len : Iir_Int64; Loc : Location_Type) + return Iir; + + -- Compute ATYPE'value (VALUE) using origin ORIG, but without checking + -- bounds. + function Eval_Value_Attribute + (Value : String; Atype : Iir; Orig : Iir) return Iir; + + -- From one-dimensional array expression PREFIX extract element at + -- offset OFF (from 0 to length - 1). Note that the element is directly + -- returned, not a copy of it (so it should be referenced if stored in + -- the tree). + function Eval_Indexed_Name_By_Offset (Prefix : Iir; Off : Iir_Index32) + return Iir; + + -- Return the simple name, character literal or operator sumbol of ID, + -- using the same format as SIMPLE_NAME attribute. + function Eval_Simple_Name (Id : Name_Id) return String; + + -- Compare two string literals (of same length). + type Compare_Type is (Compare_Lt, Compare_Eq, Compare_Gt); + function Compare_String_Literals (L, R : Iir) return Compare_Type; + + package String_Utils is + type Str_Info (Is_String : Boolean := True) is record + Len : Nat32; + + case Is_String is + when True => + Id : String8_Id; + when False => + -- A simple aggregate. List of elements. + List : Iir_Flist; + end case; + end record; + + -- Fill Res from EL. This is used to speed up Lt and Eq operations. + function Get_Str_Info (Expr : Iir) return Str_Info; + + -- Return the position of element IDX of STR. + function Get_Pos (Str : Str_Info; Idx : Nat32) return Iir_Int32; + end String_Utils; + + -- Return the local part of 'Instance_Name or 'Path_Name. + type Path_Instance_Name_Type (Len : Natural) is record + -- The node before suffix (entity, architecture or generate iterator). + Path_Instance : Iir; + + -- The suffix + Suffix : String (1 .. Len); + end record; + + function Get_Path_Instance_Name_Suffix (Attr : Iir) + return Path_Instance_Name_Type; + + -- Create a copy of VAL. + function Copy_Constant (Val : Iir) return Iir; +end Vhdl.Evaluation; diff --git a/src/vhdl/vhdl-ieee-vital_timing.adb b/src/vhdl/vhdl-ieee-vital_timing.adb index 3a343858f..0cd175a05 100644 --- a/src/vhdl/vhdl-ieee-vital_timing.adb +++ b/src/vhdl/vhdl-ieee-vital_timing.adb @@ -24,7 +24,7 @@ with Name_Table; with Vhdl.Ieee.Std_Logic_1164; use Vhdl.Ieee.Std_Logic_1164; with Vhdl.Sem_Scopes; with Vhdl.Sem_Specs; -with Evaluation; +with Vhdl.Evaluation; with Vhdl.Sem; with Iirs_Utils; @@ -569,7 +569,7 @@ package body Vhdl.Ieee.Vital_Timing is if Get_Type_Staticness (Itype) /= Locally then return Port_Length_Unknown; end if; - return Evaluation.Eval_Discrete_Type_Length (Itype); + return Vhdl.Evaluation.Eval_Discrete_Type_Length (Itype); else return Port_Length_Error; end if; @@ -639,7 +639,7 @@ package body Vhdl.Ieee.Vital_Timing is if Get_Type_Staticness (Itype) /= Locally then return Port_Length_Unknown; else - return Evaluation.Eval_Discrete_Type_Length (Itype); + return Vhdl.Evaluation.Eval_Discrete_Type_Length (Itype); end if; end Get_Timing_Generic_Type_Length; diff --git a/src/vhdl/vhdl-sem_assocs.adb b/src/vhdl/vhdl-sem_assocs.adb index 403f720ef..112ed5e2f 100644 --- a/src/vhdl/vhdl-sem_assocs.adb +++ b/src/vhdl/vhdl-sem_assocs.adb @@ -15,7 +15,7 @@ -- along with GHDL; see the file COPYING. If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. -with Evaluation; use Evaluation; +with Vhdl.Evaluation; use Vhdl.Evaluation; with Errorout; use Errorout; with Flags; use Flags; with Types; use Types; diff --git a/src/vhdl/vhdl-sem_decls.adb b/src/vhdl/vhdl-sem_decls.adb index f67fcd96c..21eefd8ae 100644 --- a/src/vhdl/vhdl-sem_decls.adb +++ b/src/vhdl/vhdl-sem_decls.adb @@ -21,7 +21,7 @@ with Std_Names; with Vhdl.Tokens; with Flags; use Flags; with Vhdl.Std_Package; use Vhdl.Std_Package; -with Evaluation; use Evaluation; +with Vhdl.Evaluation; use Vhdl.Evaluation; with Iirs_Utils; use Iirs_Utils; with Vhdl.Sem; use Vhdl.Sem; with Vhdl.Sem_Utils; use Vhdl.Sem_Utils; diff --git a/src/vhdl/vhdl-sem_expr.adb b/src/vhdl/vhdl-sem_expr.adb index cd9f9a2d5..09316fa11 100644 --- a/src/vhdl/vhdl-sem_expr.adb +++ b/src/vhdl/vhdl-sem_expr.adb @@ -26,7 +26,7 @@ with Vhdl.Sem; with Name_Table; with Str_Table; with Iirs_Utils; use Iirs_Utils; -with Evaluation; use Evaluation; +with Vhdl.Evaluation; use Vhdl.Evaluation; with Iir_Chains; use Iir_Chains; with Vhdl.Sem_Types; with Vhdl.Sem_Stmts; use Vhdl.Sem_Stmts; diff --git a/src/vhdl/vhdl-sem_names.adb b/src/vhdl/vhdl-sem_names.adb index 3f49ae99a..afb0b549b 100644 --- a/src/vhdl/vhdl-sem_names.adb +++ b/src/vhdl/vhdl-sem_names.adb @@ -15,7 +15,7 @@ -- along with GHDL; see the file COPYING. If not, write to the Free -- Software Foundation, 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. -with Evaluation; use Evaluation; +with Vhdl.Evaluation; use Vhdl.Evaluation; with Iirs_Utils; use Iirs_Utils; with Errorout; use Errorout; with Flags; use Flags; diff --git a/src/vhdl/vhdl-sem_psl.adb b/src/vhdl/vhdl-sem_psl.adb index fb812706a..a9ca225b2 100644 --- a/src/vhdl/vhdl-sem_psl.adb +++ b/src/vhdl/vhdl-sem_psl.adb @@ -27,7 +27,7 @@ with Vhdl.Sem_Scopes; with Vhdl.Sem_Names; with Std_Names; with Iirs_Utils; use Iirs_Utils; -with Evaluation; use Evaluation; +with Vhdl.Evaluation; use Vhdl.Evaluation; with Vhdl.Std_Package; with Vhdl.Ieee.Std_Logic_1164; with Errorout; use Errorout; diff --git a/src/vhdl/vhdl-sem_specs.adb b/src/vhdl/vhdl-sem_specs.adb index 3ed4ec571..ed56ade37 100644 --- a/src/vhdl/vhdl-sem_specs.adb +++ b/src/vhdl/vhdl-sem_specs.adb @@ -18,7 +18,7 @@ with Iirs_Utils; use Iirs_Utils; with Vhdl.Sem_Expr; use Vhdl.Sem_Expr; with Vhdl.Sem_Names; use Vhdl.Sem_Names; -with Evaluation; use Evaluation; +with Vhdl.Evaluation; use Vhdl.Evaluation; with Vhdl.Std_Package; use Vhdl.Std_Package; with Errorout; use Errorout; with Vhdl.Sem; use Vhdl.Sem; diff --git a/src/vhdl/vhdl-sem_stmts.adb b/src/vhdl/vhdl-sem_stmts.adb index c79f69496..deca231a6 100644 --- a/src/vhdl/vhdl-sem_stmts.adb +++ b/src/vhdl/vhdl-sem_stmts.adb @@ -28,7 +28,7 @@ with Vhdl.Sem_Scopes; use Vhdl.Sem_Scopes; with Vhdl.Sem_Types; with Vhdl.Sem_Psl; with Std_Names; -with Evaluation; use Evaluation; +with Vhdl.Evaluation; use Vhdl.Evaluation; with Iirs_Utils; use Iirs_Utils; with Xrefs; use Xrefs; diff --git a/src/vhdl/vhdl-sem_types.adb b/src/vhdl/vhdl-sem_types.adb index 7f2bcd6aa..3eb5e8fe1 100644 --- a/src/vhdl/vhdl-sem_types.adb +++ b/src/vhdl/vhdl-sem_types.adb @@ -19,7 +19,7 @@ with Libraries; with Flags; use Flags; with Types; use Types; with Errorout; use Errorout; -with Evaluation; use Evaluation; +with Vhdl.Evaluation; use Vhdl.Evaluation; with Vhdl.Sem_Utils; with Vhdl.Sem_Expr; use Vhdl.Sem_Expr; with Vhdl.Sem_Scopes; use Vhdl.Sem_Scopes; -- cgit v1.2.3