diff options
Diffstat (limited to 'evaluation.adb')
| -rw-r--r-- | evaluation.adb | 2030 |
1 files changed, 2030 insertions, 0 deletions
diff --git a/evaluation.adb b/evaluation.adb new file mode 100644 index 000000000..c64eea451 --- /dev/null +++ b/evaluation.adb @@ -0,0 +1,2030 @@ +-- 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 GCC; 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 Errorout; use Errorout; +with Name_Table; use Name_Table; +with Str_Table; +with Iirs_Utils; use Iirs_Utils; +with Std_Package; use Std_Package; +with Flags; +with Std_Names; + +package body Evaluation is + function Get_Physical_Value (Expr : Iir) return Iir_Int64 is + begin + case Get_Kind (Expr) is + when Iir_Kind_Physical_Int_Literal => + return Get_Value (Expr) + * Get_Value (Get_Physical_Unit_Value (Get_Unit_Name (Expr))); + when Iir_Kind_Unit_Declaration => + return Get_Value (Get_Physical_Unit_Value (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 (Val : Iir_Index32; Origin : Iir) + return Iir_Enumeration_Literal + is + Res : Iir_Enumeration_Literal; + Enum_Type : Iir; + Enum_List : Iir_List; + Lit : Iir_Enumeration_Literal; + begin + Enum_Type := Get_Base_Type (Get_Type (Origin)); + Enum_List := Get_Enumeration_Literal_List (Enum_Type); + Lit := Get_Nth_Element (Enum_List, Integer (Val)); + + Res := Create_Iir (Iir_Kind_Enumeration_Literal); + Set_Identifier (Res, Get_Identifier (Lit)); + Location_Copy (Res, Origin); + Set_Enum_Pos (Res, Iir_Int32 (Val)); + Set_Type (Res, Get_Type (Origin)); + Set_Literal_Origin (Res, Origin); + Set_Expr_Staticness (Res, Locally); + Set_Enumeration_Decl (Res, Lit); + return Res; + end Build_Enumeration; + + function Build_Boolean (Cond : Boolean; Origin : Iir) return Iir is + begin + return Build_Enumeration (Boolean'Pos (Cond), Origin); + end Build_Boolean; + + function Build_Physical (Val : Iir_Int64; Origin : Iir) + return Iir_Physical_Int_Literal + is + Res : Iir_Physical_Int_Literal; + begin + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Location_Copy (Res, Origin); + Set_Unit_Name (Res, Get_Primary_Unit (Get_Type (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_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 (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 : String_Id; Len : Nat32; Origin : Iir) + return Iir_String_Literal + is + Res : Iir_String_Literal; + begin + Res := Create_Iir (Iir_Kind_String_Literal); + Location_Copy (Res, Origin); + Set_String_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; + + function Build_Simple_Aggregate + (El_List : Iir_List; Origin : Iir; Stype : 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); + return Res; + end Build_Simple_Aggregate; + + 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 Get_Nth_Element + (Get_Enumeration_Literal_List + (Get_Base_Type (Get_Type (Origin))), + Integer (Get_Enum_Pos (Val))); + when Iir_Kind_Physical_Int_Literal => + declare + Prim : Iir; + begin + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Prim := Get_Primary_Unit (Get_Base_Type (Get_Type (Origin))); + Set_Unit_Name (Res, Prim); + if Get_Unit_Name (Val) = Prim then + Set_Value (Res, Get_Value (Val)); + else + raise Internal_Error; + --Set_Abstract_Literal (Res, Get_Abstract_Literal (Val) + -- * Get_Value (Get_Name (Val))); + end if; + end; + when Iir_Kind_Unit_Declaration => + Res := Create_Iir (Iir_Kind_Physical_Int_Literal); + Set_Value (Res, Get_Physical_Value (Val)); + Set_Unit_Name (Res, Get_Primary_Unit (Get_Type (Val))); + + when Iir_Kind_String_Literal => + Res := Create_Iir (Iir_Kind_String_Literal); + Set_String_Id (Res, Get_String_Id (Val)); + Set_String_Length (Res, Get_String_Length (Val)); + + when Iir_Kind_Bit_String_Literal => + Res := Create_Iir (Iir_Kind_Bit_String_Literal); + Set_String_Id (Res, Get_String_Id (Val)); + Set_String_Length (Res, Get_String_Length (Val)); + Set_Bit_String_Base (Res, Get_Bit_String_Base (Val)); + Set_Bit_String_0 (Res, Get_Bit_String_0 (Val)); + Set_Bit_String_1 (Res, Get_Bit_String_1 (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_Error => + return Val; + + 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; + + -- 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 + Left, Right : Iir; + Pos : Iir_Int64; + A_Type : Iir; + begin + if Get_Expr_Staticness (A_Range) /= Locally then + raise Internal_Error; + end if; + A_Type := Get_Type (A_Range); + + Left := Get_Left_Limit (A_Range); + + 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 ("range length is beyond subtype length", A_Range); + Right := Left; + else + -- FIXME: what about nul range? + Right := Build_Discrete (Pos, A_Range); + Set_Literal_Origin (Right, Null_Iir); + 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 + if Get_Type_Staticness (A_Type) /= Locally then + raise Internal_Error; + end if; + + 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 + if Get_Type_Staticness (A_Type) /= Locally then + raise Internal_Error; + end if; + + 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)); + Append_Element (Get_Index_Subtype_List (Res), Index_Type); + Set_Type_Staticness (Res, Min (Get_Type_Staticness (Res), + Get_Type_Staticness (Index_Type))); + 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 : Iir; + N_Index_Type : Iir; + begin + Index_Type := Get_First_Element (Get_Index_Subtype_List (Base_Type)); + 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; + + function Eval_String_Literal (Str : Iir) return Iir + is + use Name_Table; + Ptr : String_Fat_Acc; + Len : Natural; + begin + case Get_Kind (Str) is + when Iir_Kind_String_Literal => + declare + Element_Type : Iir; + Literal_List : Iir_List; + Lit : Iir; + + List : Iir_List; + begin + Element_Type := Get_Base_Type + (Get_Element_Subtype (Get_Base_Type (Get_Type (Str)))); + Literal_List := Get_Enumeration_Literal_List (Element_Type); + List := Create_Iir_List; + + Ptr := Get_String_Fat_Acc (Str); + Len := Get_String_Length (Str); + + for I in 1 .. Len loop + Lit := Find_Name_In_List + (Literal_List, + Name_Table.Get_Identifier (Ptr (I))); + Append_Element (List, Lit); + end loop; + return Build_Simple_Aggregate (List, Str, Get_Type (Str)); + end; + when Iir_Kind_Bit_String_Literal => + declare + Str_Type : Iir; + List : Iir_List; + Lit_0 : Iir; + Lit_1 : Iir; + begin + Str_Type := Get_Type (Str); + List := Create_Iir_List; + Lit_0 := Get_Bit_String_0 (Str); + Lit_1 := Get_Bit_String_1 (Str); + + Ptr := Get_String_Fat_Acc (Str); + Len := Get_String_Length (Str); + + for I in 1 .. Len loop + case Ptr (I) is + when '0' => + Append_Element (List, Lit_0); + when '1' => + Append_Element (List, Lit_1); + when others => + raise Internal_Error; + end case; + end loop; + return Build_Simple_Aggregate (List, Str, Str_Type); + end; + 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); + + Func : Iir_Predefined_Functions; + begin + 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 + (Boolean'Pos (Get_Enum_Pos (Operand) = 0), Orig); + + when Iir_Predefined_Bit_Array_Not => + declare + O_List : Iir_List; + R_List : Iir_List; + El : Iir; + Lit : Iir; + begin + O_List := Get_Simple_Aggregate_List + (Eval_String_Literal (Operand)); + R_List := Create_Iir_List; + + for I in Natural loop + El := Get_Nth_Element (O_List, I); + exit when El = Null_Iir; + case Get_Enum_Pos (El) is + when 0 => + Lit := Bit_1; + when 1 => + Lit := Bit_0; + when others => + raise Internal_Error; + end case; + Append_Element (R_List, Lit); + end loop; + return Build_Simple_Aggregate + (R_List, Orig, Get_Type (Operand)); + end; + when others => + Error_Internal (Orig, "eval_monadic_operator: " & + Iir_Predefined_Functions'Image (Func)); + end case; + exception + when Constraint_Error => + Error_Msg_Sem ("arithmetic overflow in static expression", Orig); + return Orig; + end Eval_Monadic_Operator; + + function Eval_Dyadic_Bit_Array_Operator + (Expr : Iir; + Left, Right : Iir; + Func : Iir_Predefined_Dyadic_Bit_Array_Functions) + return Iir + is + use Str_Table; + L_Str : String_Fat_Acc := Get_String_Fat_Acc (Left); + R_Str : String_Fat_Acc := Get_String_Fat_Acc (Right); + Len : Natural; + Id : String_Id; + begin + Len := Get_String_Length (Left); + if Len /= Get_String_Length (Right) then + Error_Msg_Sem ("length of left and right operands mismatch", Expr); + return Left; + else + Id := Start; + case Func is + when Iir_Predefined_Bit_Array_And => + for I in 1 .. Len loop + case L_Str (I) is + when '0' => + Append ('0'); + when '1' => + Append (R_Str (I)); + when others => + raise Internal_Error; + end case; + end loop; + when Iir_Predefined_Bit_Array_Nand => + for I in 1 .. Len loop + case L_Str (I) is + when '0' => + Append ('1'); + when '1' => + case R_Str (I) is + when '0' => + Append ('1'); + when '1' => + Append ('0'); + when others => + raise Internal_Error; + end case; + when others => + raise Internal_Error; + end case; + end loop; + when Iir_Predefined_Bit_Array_Or => + for I in 1 .. Len loop + case L_Str (I) is + when '1' => + Append ('1'); + when '0' => + Append (R_Str (I)); + when others => + raise Internal_Error; + end case; + end loop; + when Iir_Predefined_Bit_Array_Nor => + for I in 1 .. Len loop + case L_Str (I) is + when '1' => + Append ('0'); + when '0' => + case R_Str (I) is + when '0' => + Append ('1'); + when '1' => + Append ('0'); + when others => + raise Internal_Error; + end case; + when others => + raise Internal_Error; + end case; + end loop; + when Iir_Predefined_Bit_Array_Xor => + for I in 1 .. Len loop + case L_Str (I) is + when '1' => + case R_Str (I) is + when '0' => + Append ('1'); + when '1' => + Append ('0'); + when others => + raise Internal_Error; + end case; + when '0' => + case R_Str (I) is + when '0' => + Append ('0'); + when '1' => + Append ('1'); + when others => + raise Internal_Error; + end case; + 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; + Finish; + return Build_String (Id, Nat32 (Len), Left); + 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 + Error_Msg_Sem ("division by 0", Expr); + 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 : Iir_Int64; + Cnt : Natural; + Len : Natural; + Arr_List : Iir_List; + Res_List : Iir_List; + Dir_Left : Boolean; + E : Iir; + begin + Count := Get_Value (Right); + Arr_List := Get_Simple_Aggregate_List (Left); + Len := Get_Nbr_Elements (Arr_List); + -- 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 : Iir_List; + begin + Enum_List := Get_Enumeration_Literal_List + (Get_Base_Type (Get_Element_Subtype (Get_Type (Left)))); + 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; + end if; + when others => + raise Internal_Error; + end case; + + Res_List := Create_Iir_List; + + 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 + Append_Element + (Res_List, Get_Nth_Element (Arr_List, I)); + end loop; + else + Cnt := Len; + end if; + for I in 0 .. Cnt - 1 loop + Append_Element (Res_List, E); + end loop; + else + if Cnt > Len then + Cnt := Len; + end if; + for I in 0 .. Cnt - 1 loop + Append_Element (Res_List, E); + end loop; + for I in Cnt .. Len - 1 loop + Append_Element + (Res_List, 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 + Append_Element + (Res_List, 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_List; + L : Natural; + Res_Type : Iir; + Origin_Type : Iir; + Left_List, Right_List : Iir_List; + begin + Res_List := Create_Iir_List; + -- Do the concatenation. + -- Left: + case Func is + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Element_Element_Concat => + Append_Element (Res_List, Left); + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Array_Array_Concat => + Left_List := + Get_Simple_Aggregate_List (Eval_String_Literal (Left)); + L := Get_Nbr_Elements (Left_List); + for I in 0 .. L - 1 loop + Append_Element (Res_List, Get_Nth_Element (Left_List, I)); + end loop; + end case; + -- Right: + case Func is + when Iir_Predefined_Array_Element_Concat + | Iir_Predefined_Element_Element_Concat => + Append_Element (Res_List, Right); + when Iir_Predefined_Element_Array_Concat + | Iir_Predefined_Array_Array_Concat => + Right_List := + Get_Simple_Aggregate_List (Eval_String_Literal (Right)); + L := Get_Nbr_Elements (Right_List); + for I in 0 .. L - 1 loop + Append_Element (Res_List, Get_Nth_Element (Right_List, I)); + end loop; + end case; + L := Get_Nbr_Elements (Res_List); + + -- Compute subtype... + Origin_Type := Get_Type (Orig); + Res_Type := Null_Iir; + if Func = Iir_Predefined_Array_Array_Concat + and then Get_Nbr_Elements (Left_List) = 0 + then + if Flags.Vhdl_Std = Vhdl_87 then + -- LRM87 7.2.4 + -- [...], 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.4 + -- The left bound of the result is the left operand, [...] + -- + -- LRM87 7.2.4 + -- The direction of the result is the direction of the left + -- operand, [...] + declare + A_Range : Iir; + Left_Index : Iir; + Left_Range : Iir; + Index_Type : Iir; + Ret_Type : Iir; + begin + Left_Index := Get_Nth_Element + (Get_Index_Subtype_List (Get_Type (Left)), 0); + Left_Range := Get_Range_Constraint (Left_Index); + + A_Range := Create_Iir (Iir_Kind_Range_Expression); + Ret_Type := Get_Return_Type (Get_Implementation (Orig)); + Set_Type + (A_Range, + Get_First_Element (Get_Index_Subtype_List (Ret_Type))); + 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 (L)); + 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 (L), 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); + end Eval_Concatenation; + + -- ORIG is either a dyadic operator or a function call. + function Eval_Dyadic_Operator (Orig : Iir; Left, Right : Iir) + return Iir + is + pragma Unsuppress (Overflow_Check); + Func : Iir_Predefined_Functions; + begin + if Get_Kind (Left) = Iir_Kind_Error + or else Get_Kind (Right) = Iir_Kind_Error + then + return Null_Iir; + end if; + + Func := Get_Implicit_Definition (Get_Implementation (Orig)); + 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 Null_Iir; + 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 Null_Iir; + 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 Null_Iir; + 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), Orig); + when Iir_Predefined_Integer_Inequality => + return Build_Boolean (Get_Value (Left) /= Get_Value (Right), Orig); + when Iir_Predefined_Integer_Greater_Equal => + return Build_Boolean (Get_Value (Left) >= Get_Value (Right), Orig); + when Iir_Predefined_Integer_Greater => + return Build_Boolean (Get_Value (Left) > Get_Value (Right), Orig); + when Iir_Predefined_Integer_Less_Equal => + return Build_Boolean (Get_Value (Left) <= Get_Value (Right), Orig); + when Iir_Predefined_Integer_Less => + return Build_Boolean (Get_Value (Left) < Get_Value (Right), Orig); + + when Iir_Predefined_Floating_Equality => + return Build_Boolean + (Get_Fp_Value (Left) = Get_Fp_Value (Right), Orig); + when Iir_Predefined_Floating_Inequality => + return Build_Boolean + (Get_Fp_Value (Left) /= Get_Fp_Value (Right), Orig); + when Iir_Predefined_Floating_Greater => + return Build_Boolean + (Get_Fp_Value (Left) > Get_Fp_Value (Right), Orig); + when Iir_Predefined_Floating_Greater_Equal => + return Build_Boolean + (Get_Fp_Value (Left) >= Get_Fp_Value (Right), Orig); + when Iir_Predefined_Floating_Less => + return Build_Boolean + (Get_Fp_Value (Left) < Get_Fp_Value (Right), Orig); + when Iir_Predefined_Floating_Less_Equal => + return Build_Boolean + (Get_Fp_Value (Left) <= Get_Fp_Value (Right), Orig); + + 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 + Error_Msg_Sem ("right operand of division is 0", Orig); + return Build_Floating (0.0, 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); + 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; + if Get_Value (Right) < 0 then + Res := 1.0 / Res; + end if; + return Build_Floating (Res, Orig); + end; + + when Iir_Predefined_Physical_Equality => + return Build_Boolean + (Get_Physical_Value (Left) = Get_Physical_Value (Right), Orig); + when Iir_Predefined_Physical_Inequality => + return Build_Boolean + (Get_Physical_Value (Left) /= Get_Physical_Value (Right), Orig); + when Iir_Predefined_Physical_Greater_Equal => + return Build_Boolean + (Get_Physical_Value (Left) >= Get_Physical_Value (Right), Orig); + when Iir_Predefined_Physical_Greater => + return Build_Boolean + (Get_Physical_Value (Left) > Get_Physical_Value (Right), Orig); + when Iir_Predefined_Physical_Less_Equal => + return Build_Boolean + (Get_Physical_Value (Left) <= Get_Physical_Value (Right), Orig); + when Iir_Predefined_Physical_Less => + return Build_Boolean + (Get_Physical_Value (Left) < Get_Physical_Value (Right), Orig); + + 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_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 => + return Build_Boolean + (Get_Enum_Pos (Left) = Get_Enum_Pos (Right), Orig); + when Iir_Predefined_Enum_Inequality => + return Build_Boolean + (Get_Enum_Pos (Left) /= Get_Enum_Pos (Right), Orig); + when Iir_Predefined_Enum_Greater_Equal => + return Build_Boolean + (Get_Enum_Pos (Left) >= Get_Enum_Pos (Right), Orig); + when Iir_Predefined_Enum_Greater => + return Build_Boolean + (Get_Enum_Pos (Left) > Get_Enum_Pos (Right), Orig); + when Iir_Predefined_Enum_Less_Equal => + return Build_Boolean + (Get_Enum_Pos (Left) <= Get_Enum_Pos (Right), Orig); + when Iir_Predefined_Enum_Less => + return Build_Boolean + (Get_Enum_Pos (Left) < Get_Enum_Pos (Right), Orig); + + when Iir_Predefined_Boolean_And + | Iir_Predefined_Bit_And => + return Build_Boolean + (Get_Enum_Pos (Left) = 1 and Get_Enum_Pos (Right) = 1, Orig); + when Iir_Predefined_Boolean_Nand + | Iir_Predefined_Bit_Nand => + return Build_Boolean + (not (Get_Enum_Pos (Left) = 1 and Get_Enum_Pos (Right) = 1), + Orig); + when Iir_Predefined_Boolean_Or + | Iir_Predefined_Bit_Or => + return Build_Boolean + (Get_Enum_Pos (Left) = 1 or Get_Enum_Pos (Right) = 1, Orig); + when Iir_Predefined_Boolean_Nor + | Iir_Predefined_Bit_Nor => + return Build_Boolean + (not (Get_Enum_Pos (Left) = 1 or Get_Enum_Pos (Right) = 1), + Orig); + when Iir_Predefined_Boolean_Xor + | Iir_Predefined_Bit_Xor => + return Build_Boolean + (Get_Enum_Pos (Left) = 1 xor Get_Enum_Pos (Right) = 1, Orig); + when Iir_Predefined_Boolean_Xnor + | Iir_Predefined_Bit_Xnor => + return Build_Boolean + (not (Get_Enum_Pos (Left) = 1 xor Get_Enum_Pos (Right) = 1), + Orig); + + when Iir_Predefined_Dyadic_Bit_Array_Functions => + 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_Array_Equality => + declare + L_List : Iir_List; + R_List : Iir_List; + R : Boolean; + N : Natural; + begin + -- FIXME: the simple aggregates are lost. + L_List := + Get_Simple_Aggregate_List (Eval_String_Literal (Left)); + R_List := + Get_Simple_Aggregate_List (Eval_String_Literal (Right)); + N := Get_Nbr_Elements (L_List); + if N /= Get_Nbr_Elements (R_List) then + R := False; + else + R := True; + for I in 0 .. N - 1 loop + -- FIXME: this is wrong: (eg: evaluated lit) + if Get_Nth_Element (L_List, I) + /= Get_Nth_Element (R_List, I) + then + R := False; + exit; + end if; + end loop; + end if; + return Build_Boolean (R, Orig); + end; + + 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 => + return Eval_Shift_Operator + (Eval_String_Literal (Left), Right, Orig, Func); + + when Iir_Predefined_Boolean_Not + | Iir_Predefined_Bit_Not + | 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 => + -- Not binary or never locally static. + Error_Internal (Orig, "eval_dyadic_operator: " & + Iir_Predefined_Functions'Image (Func)); + when others => + Error_Internal (Orig, "eval_dyadic_operator: " & + Iir_Predefined_Functions'Image (Func)); + end case; + exception + when Constraint_Error => + Error_Msg_Sem ("arithmetic overflow in static expression", Orig); + return Null_Iir; + end Eval_Dyadic_Operator; + + -- Evaluate any array attribute + function Eval_Array_Attribute (Attr : Iir) return Iir + is + Prefix : Iir; + Prefix_Type : Iir; + begin + Prefix := Get_Prefix (Attr); + case Get_Kind (Prefix) is + when Iir_Kinds_Object_Declaration + | Iir_Kind_Selected_Element + | Iir_Kind_Indexed_Name + | Iir_Kind_Slice_Name + | Iir_Kind_Subtype_Declaration + | Iir_Kind_Type_Declaration + | Iir_Kind_Implicit_Dereference => + Prefix_Type := Get_Type (Prefix); + when Iir_Kind_Attribute_Value => + -- The type of the attribute declaration may be unconstrained. + Prefix_Type := Get_Type + (Get_Expression (Get_Attribute_Specification (Prefix))); + when Iir_Kinds_Subtype_Definition => + Prefix_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; + return Get_Nth_Element (Get_Index_Subtype_List (Prefix_Type), + Natural (Get_Value (Get_Parameter (Attr)) - 1)); + end Eval_Array_Attribute; + + function Eval_Incdec (Expr : Iir; N : Iir_Int64) return Iir + is + P : Iir_Int64; + begin + case Get_Kind (Expr) is + when Iir_Kind_Integer_Literal => + return Build_Integer (Get_Value (Expr) + N, Expr); + when Iir_Kind_Enumeration_Literal => + P := Iir_Int64 (Get_Enum_Pos (Expr)) + N; + if P < 0 then + Error_Msg_Sem ("static constant violates bounds", Expr); + return Expr; + else + return Build_Enumeration (Iir_Index32 (P), Expr); + end if; + when Iir_Kind_Physical_Int_Literal => + return Build_Physical (Get_Value (Expr) + N, Expr); + 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; + begin + Res_Btype := Get_Base_Type (Res_Type); + Res := Create_Iir (Iir_Kind_Range_Expression); + Location_Copy (Res, Loc); + Set_Type (Res, Res_Btype); + Set_Left_Limit (Res, Create_Bound (Get_Left_Limit (Rng))); + Set_Right_Limit (Res, Create_Bound (Get_Right_Limit (Rng))); + 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 : Iir; + Res : Iir; + Val_Type : Iir; + Conv_Index_Type : Iir; + Val_Index_Type : Iir; + Index_Type : Iir; + Rng : Iir; + begin + Conv_Type := Get_Type (Conv); + Conv_Index_Type := Get_Nth_Element + (Get_Index_Subtype_List (Conv_Type), 0); + Val_Type := Get_Type (Val); + Val_Index_Type := Get_Nth_Element + (Get_Index_Subtype_List (Val_Type), 0); + + -- The expression is either a simple aggregate or a (bit) string. + Res := Build_Constant (Val, Conv); + case Get_Kind (Conv_Type) is + when Iir_Kind_Array_Subtype_Definition => + Set_Type (Res, Conv_Type); + if Eval_Discrete_Type_Length (Conv_Index_Type) + /= Eval_Discrete_Type_Length (Val_Index_Type) + then + Error_Msg_Sem ("non matching length in type convertion", Conv); + end if; + return Res; + when Iir_Kind_Array_Type_Definition + | Iir_Kind_Unconstrained_Array_Subtype_Definition => + 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; + Set_Type (Res, + Create_Unidim_Array_From_Index + (Get_Base_Type (Conv_Type), Index_Type, Conv)); + return Res; + when others => + Error_Kind ("eval_array_type_conversion", Conv_Type); + end case; + end Eval_Array_Type_Conversion; + + function Eval_Type_Conversion (Expr : Iir) return Iir + is + Val : Iir; + Val_Type : Iir; + Conv_Type : Iir; + begin + Val := Eval_Expr (Get_Expression (Expr)); + Set_Expression (Expr, Val); + Val_Type := Get_Base_Type (Get_Type (Val)); + Conv_Type := Get_Base_Type (Get_Type (Expr)); + if Conv_Type = Val_Type then + return Build_Constant (Val, Expr); + end if; + case Get_Kind (Conv_Type) is + when Iir_Kind_Integer_Type_Definition => + case Get_Kind (Val_Type) is + when Iir_Kind_Integer_Type_Definition => + return Build_Integer (Get_Value (Val), Expr); + when Iir_Kind_Floating_Type_Definition => + return Build_Integer (Iir_Int64 (Get_Fp_Value (Val)), Expr); + 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 => + return Build_Floating (Iir_Fp64 (Get_Value (Val)), Expr); + when Iir_Kind_Floating_Type_Definition => + return Build_Floating (Get_Fp_Value (Val), Expr); + when others => + Error_Kind ("eval_type_conversion(2)", Val_Type); + end case; + when Iir_Kind_Array_Type_Definition => + return Eval_Array_Type_Conversion (Expr, Val); + when others => + Error_Kind ("eval_type_conversion(3)", Conv_Type); + end case; + end Eval_Type_Conversion; + + function Eval_Static_Expr (Expr: Iir) return Iir + is + Res : Iir; + Val : Iir; + begin + case Get_Kind (Expr) is + when Iir_Kind_Integer_Literal => + return Expr; + when Iir_Kind_Enumeration_Literal => + return Expr; + when Iir_Kind_Floating_Point_Literal => + return Expr; + when Iir_Kind_String_Literal => + return Expr; + when Iir_Kind_Bit_String_Literal => + return Expr; + when Iir_Kind_Physical_Int_Literal => + if Get_Unit_Name (Expr) + = Get_Primary_Unit (Get_Base_Type (Get_Type (Expr))) + then + return Expr; + else + return Build_Physical (Get_Physical_Value (Expr), Expr); + end if; + when Iir_Kind_Physical_Fp_Literal => + return Build_Physical + (Iir_Int64 (Get_Fp_Value (Expr) + * Iir_Fp64 (Get_Value (Get_Physical_Unit_Value + (Get_Unit_Name (Expr))))), + Expr); + when Iir_Kind_Constant_Declaration => + Val := Get_Default_Value (Expr); + Res := Build_Constant (Val, Expr); + Set_Type (Res, Get_Type (Val)); + return Res; + when Iir_Kind_Object_Alias_Declaration => + return Build_Constant (Eval_Static_Expr (Get_Name (Expr)), Expr); + when Iir_Kind_Unit_Declaration => + return Expr; + when Iir_Kind_Simple_Aggregate => + return Expr; + + when Iir_Kind_Qualified_Expression => + return Build_Constant (Eval_Expr (Get_Expression (Expr)), Expr); + when Iir_Kind_Type_Conversion => + return Eval_Type_Conversion (Expr); + when Iir_Kind_Range_Expression => + Set_Left_Limit (Expr, Eval_Expr (Get_Left_Limit (Expr))); + Set_Right_Limit (Expr, Eval_Expr (Get_Right_Limit (Expr))); + return Expr; + + when Iir_Kinds_Monadic_Operator => + declare + Operand : Iir; + begin + Operand := Eval_Expr (Get_Operand (Expr)); + Set_Operand (Expr, Operand); + return Eval_Monadic_Operator (Expr, Operand); + end; + when Iir_Kinds_Dyadic_Operator => + declare + Left, Right : Iir; + begin + Left := Eval_Expr (Get_Left (Expr)); + Right := Eval_Expr (Get_Right (Expr)); + + Set_Left (Expr, Left); + Set_Right (Expr, Right); + return Eval_Dyadic_Operator (Expr, Left, Right); + end; + + when Iir_Kind_Attribute_Value => + -- FIXME. + -- Currently, this avoids weird nodes, such as a string literal + -- whose type is an unconstrained array type. + Val := Get_Expression (Get_Attribute_Specification (Expr)); + Res := Build_Constant (Val, Expr); + Set_Type (Res, Get_Type (Val)); + return Res; + + when Iir_Kind_Pos_Attribute => + declare + Val : Iir; + begin + Val := Eval_Expr (Get_Parameter (Expr)); + Set_Parameter (Expr, Val); + return Build_Integer (Eval_Pos (Val), Expr); + end; + when Iir_Kind_Val_Attribute => + declare + Val_Expr : Iir; + Val : Iir_Int64; + Expr_Type : Iir; + begin + Val_Expr := Eval_Expr (Get_Parameter (Expr)); + Set_Parameter (Expr, Val_Expr); + Val := Eval_Pos (Val_Expr); + -- Note: the type of 'val is a base type. + Expr_Type := Get_Type (Expr); + -- 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 + Error_Msg_Sem + ("static argument out of the type range", Expr); + Val := 0; + 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_Left_Type_Attribute => + return Build_Constant + (Get_Left_Limit (Eval_Range (Get_Type (Expr))), Expr); + when Iir_Kind_Right_Type_Attribute => + return Build_Constant + (Get_Right_Limit (Eval_Range (Get_Type (Expr))), Expr); + when Iir_Kind_High_Type_Attribute => + return Build_Constant + (Get_High_Limit (Eval_Range (Get_Type (Expr))), Expr); + when Iir_Kind_Low_Type_Attribute => + return Build_Constant + (Get_Low_Limit (Eval_Range (Get_Type (Expr))), Expr); + when Iir_Kind_Ascending_Type_Attribute => + return Build_Boolean + (Get_Direction (Eval_Range (Get_Type (Expr))) = Iir_To, Expr); + + when Iir_Kind_Range_Array_Attribute => + declare + Index : Iir; + begin + Index := Eval_Array_Attribute (Expr); + return Get_Range_Constraint (Index); + end; + when Iir_Kind_Reverse_Range_Array_Attribute => + declare + Res : Iir; + Rng : Iir; + begin + Rng := Get_Range_Constraint (Eval_Array_Attribute (Expr)); + Res := Create_Iir (Iir_Kind_Range_Expression); + Location_Copy (Res, Rng); + Set_Type (Res, Get_Type (Rng)); + case Get_Direction (Rng) 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 (Rng)); + Set_Right_Limit (Res, Get_Left_Limit (Rng)); + -- FIXME: todo. + --Set_Literal_Origin (Res, Rng); + Set_Expr_Staticness (Res, Get_Expr_Staticness (Rng)); + return Res; + end; + 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 Build_Constant + (Get_Left_Limit (Get_Range_Constraint (Index)), Expr); + end; + when Iir_Kind_Right_Array_Attribute => + declare + Index : Iir; + begin + Index := Eval_Array_Attribute (Expr); + return Build_Constant + (Get_Right_Limit (Get_Range_Constraint (Index)), Expr); + end; + when Iir_Kind_Low_Array_Attribute => + declare + Index : Iir; + begin + Index := Eval_Array_Attribute (Expr); + return Build_Constant + (Get_Low_Limit (Get_Range_Constraint (Index)), Expr); + end; + when Iir_Kind_High_Array_Attribute => + declare + Index : Iir; + begin + Index := Eval_Array_Attribute (Expr); + return Build_Constant + (Get_High_Limit (Get_Range_Constraint (Index)), Expr); + 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, Expr); + end; + + when Iir_Kind_Pred_Attribute => + Res := Eval_Incdec (Eval_Static_Expr (Get_Parameter (Expr)), -1); + 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); + 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 : Iir; + Res : Iir; + begin + Prefix_Type := Get_Type (Get_Prefix (Expr)); + Rng := Eval_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); + Eval_Check_Bound (Res, Prefix_Type); + return Res; + end; + + when Iir_Kind_Simple_Name_Attribute => + declare + use Str_Table; + Id : String_Id; + begin + Id := Start; + Image (Get_Simple_Name_Identifier (Expr)); + for I in 1 .. Name_Length loop + Append (Name_Buffer (I)); + end loop; + Finish; + return Build_String (Id, Nat32 (Name_Length), Expr); + end; + + when Iir_Kind_Null_Literal => + return Expr; + + when Iir_Kind_Function_Call => + declare + Left, Right : Iir; + begin + -- Note: there can't be association by name. + Left := Get_Parameter_Association_Chain (Expr); + Right := Get_Chain (Left); + if Right = Null_Iir then + return Eval_Monadic_Operator (Expr, Get_Actual (Left)); + else + return Eval_Dyadic_Operator + (Expr, Get_Actual (Left), Get_Actual (Right)); + end if; + end; + + when Iir_Kind_Simple_Name + | Iir_Kind_Selected_Name => + declare + Res : Iir; + Orig : Iir; + begin + Orig := Get_Named_Entity (Expr); + Res := Eval_Static_Expr (Orig); + if Res /= Orig then + Location_Copy (Res, Expr); + end if; + Free_Name (Expr); + return Res; + end; + when Iir_Kind_Error => + return Expr; + when others => + Error_Kind ("eval_static_expr", Expr); + end case; + end Eval_Static_Expr; + + function Eval_Expr (Expr: Iir) return Iir is + begin + if Get_Expr_Staticness (Expr) /= Locally then + Error_Msg_Sem ("expression must be locally static", Expr); + return Expr; + else + return Eval_Static_Expr (Expr); + end if; + end Eval_Expr; + + function Eval_Expr_If_Static (Expr : Iir) return Iir is + begin + if Expr /= Null_Iir and then Get_Expr_Staticness (Expr) = Locally then + return Eval_Static_Expr (Expr); + else + return Expr; + end if; + end Eval_Expr_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 TRUE if literal EXPR is in SUB_TYPE bounds. + function Eval_Is_In_Bound (Expr : Iir; Sub_Type : Iir) + return Boolean + is + Type_Range : Iir; + begin + if Get_Kind (Expr) = Iir_Kind_Error then + return True; + end if; + + case Get_Kind (Sub_Type) is + when Iir_Kind_Integer_Subtype_Definition => + Type_Range := Get_Range_Constraint (Sub_Type); + return Eval_Int_In_Range (Get_Value (Expr), Type_Range); + when Iir_Kind_Floating_Subtype_Definition => + Type_Range := Get_Range_Constraint (Sub_Type); + return Eval_Fp_In_Range (Get_Fp_Value (Expr), Type_Range); + when Iir_Kind_Enumeration_Subtype_Definition + | Iir_Kind_Enumeration_Type_Definition => + -- 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 (Expr)), Type_Range); + when Iir_Kind_Physical_Subtype_Definition => + Type_Range := Get_Range_Constraint (Sub_Type); + return Eval_Phys_In_Range (Get_Physical_Value (Expr), Type_Range); + + when Iir_Kind_Base_Attribute => + return Eval_Is_In_Bound (Expr, Get_Type (Sub_Type)); + + when Iir_Kind_Array_Subtype_Definition + | Iir_Kind_Array_Type_Definition + | Iir_Kind_Record_Type_Definition => + -- FIXME: do it. + return True; + + --when Iir_Kind_Integer_Type_Definition => + -- This case should not happen but it may be called to check a + -- simple choice value belongs to the *type* of the case + -- expression. + -- Of course, this is always true. + -- return True; + + when others => + Error_Kind ("eval_is_in_bound", Sub_Type); + return False; + end case; + end Eval_Is_In_Bound; + + procedure Eval_Check_Bound (Expr : Iir; Sub_Type : Iir) + is + begin + if not Eval_Is_In_Bound (Expr, Sub_Type) then + Error_Msg_Sem ("static constant violates bounds", Expr); + end if; + end Eval_Check_Bound; + + function Eval_Is_Range_In_Bound (A_Range : Iir; Sub_Type : Iir) + return Boolean + is + Type_Range : Iir; + begin + Type_Range := Get_Range_Constraint (Sub_Type); + if Get_Direction (Type_Range) /= Get_Direction (A_Range) 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 (A_Range)); + R := Eval_Pos (Get_Right_Limit (A_Range)); + case Get_Direction (A_Range) 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 (A_Range)); + R := Get_Fp_Value (Get_Right_Limit (A_Range)); + case Get_Direction (A_Range) 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) + is + begin + if not Eval_Is_Range_In_Bound (A_Range, Sub_Type) then + Error_Msg_Sem ("static range violates bounds", A_Range); + end if; + end Eval_Check_Range; + + function Eval_Expr_Check (Expr : Iir; Sub_Type : Iir) return Iir + is + Res : Iir; + begin + Res := Eval_Expr (Expr); + Eval_Check_Bound (Res, Sub_Type); + return Res; + end Eval_Expr_Check; + + function Eval_Discrete_Range_Length (Constraint : Iir) return Iir_Int64 + is + 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 => + return Get_Physical_Value (Expr); + when Iir_Kind_Unit_Declaration => + return Get_Value (Get_Physical_Unit_Value (Expr)); + when others => + Error_Kind ("eval_pos", Expr); + end case; + end Eval_Pos; + + function Eval_Range (Rng : Iir) return Iir + is + Expr : Iir; + begin + Expr := Rng; + loop + case Get_Kind (Expr) is + when Iir_Kind_Range_Expression => + 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 => + declare + Prefix : Iir; + 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; + Expr := Get_Nth_Element + (Get_Index_Subtype_List (Prefix), + Natural (Eval_Pos (Get_Parameter (Expr))) - 1); + end; + when others => + Error_Kind ("eval_range", Expr); + end case; + end loop; + end Eval_Range; + + -- Return the range constraint of a discrete range. + function Eval_Discrete_Range_Expression (Constraint : Iir) return Iir + is + Res : Iir; + begin + Res := Eval_Range (Constraint); + if Res = Null_Iir then + Error_Kind ("eval_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; + + procedure Eval_Operator_Symbol_Name (Id : Name_Id) + is + begin + Image (Id); + Name_Buffer (2 .. Name_Length + 1) := Name_Buffer (1 .. Name_Length); + Name_Buffer (1) := '"'; --" + Name_Length := Name_Length + 2; + Name_Buffer (Name_Length) := '"'; --" + end Eval_Operator_Symbol_Name; + + procedure Eval_Simple_Name (Id : Name_Id) + is + begin + -- LRM 14.1 + -- E'SIMPLE_NAME + -- Result: [...] but with apostrophes (in the case of a character + -- literal) + if Is_Character (Id) then + Name_Buffer (1) := '''; + Name_Buffer (2) := Get_Character (Id); + Name_Buffer (3) := '''; + Name_Length := 3; + return; + end if; + case Id is + when Std_Names.Name_Word_Operators + | Std_Names.Name_First_Operator .. Std_Names.Name_Last_Operator => + Eval_Operator_Symbol_Name (Id); + return; + when Std_Names.Name_Xnor + | Std_Names.Name_Shift_Operators => + if Flags.Vhdl_Std > Vhdl_87 then + Eval_Operator_Symbol_Name (Id); + return; + end if; + when others => + null; + end case; + Image (Id); +-- if Name_Buffer (1) = '\' then +-- declare +-- I : Natural; +-- begin +-- I := 2; +-- while I <= Name_Length loop +-- if Name_Buffer (I) = '\' then +-- Name_Length := Name_Length + 1; +-- Name_Buffer (I + 1 .. Name_Length) := +-- Name_Buffer (I .. Name_Length - 1); +-- I := I + 1; +-- end if; +-- I := I + 1; +-- end loop; +-- Name_Length := Name_Length + 1; +-- Name_Buffer (Name_Length) := '\'; +-- end; +-- end if; + end Eval_Simple_Name; +end Evaluation; |