-- 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 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; use Flags; with Std_Names; with Ada.Characters.Handling; package body Evaluation is function Get_Physical_Value (Expr : Iir) return Iir_Int64 is pragma Unsuppress (Overflow_Check); 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; exception when Constraint_Error => Error_Msg_Sem ("arithmetic overflow in physical expression", Expr); return Get_Value (Expr); 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 -- The left limit must be locally static in order to compute the right -- limit. 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))); 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 : 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 Ptr : String_Fat_Acc; Len : Nat32; 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 : constant String_Fat_Acc := Get_String_Fat_Acc (Left); R_Str : constant String_Fat_Acc := Get_String_Fat_Acc (Right); Len : Nat32; 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, 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; 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; function Eval_Array_Equality (Left, Right : Iir) return Boolean is L_List : Iir_List; R_List : Iir_List; 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 return False; end if; 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 return False; end if; end loop; return True; end Eval_Array_Equality; -- 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 Create_Error_Expr (Orig, Get_Type (Orig)); 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_Universal_R_I_Div => return Build_Floating (Get_Fp_Value (Left) / Iir_Fp64 (Get_Value (Right)), Orig); when Iir_Predefined_Array_Equality => return Build_Boolean (Eval_Array_Equality (Left, Right), Orig); when Iir_Predefined_Array_Inequality => return Build_Boolean (not Eval_Array_Equality (Left, 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 => return Eval_Shift_Operator (Eval_String_Literal (Left), Right, Orig, Func); when Iir_Predefined_Array_Less | Iir_Predefined_Array_Less_Equal | Iir_Predefined_Array_Greater | Iir_Predefined_Array_Greater_Equal | Iir_Predefined_Boolean_Array_And | Iir_Predefined_Boolean_Array_Nand | Iir_Predefined_Boolean_Array_Or | Iir_Predefined_Boolean_Array_Nor | Iir_Predefined_Boolean_Array_Xor | Iir_Predefined_Boolean_Array_Xnor => -- FIXME: todo. Error_Internal (Orig, "eval_dyadic_operator: " & Iir_Predefined_Functions'Image (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 | Iir_Predefined_Bit_Array_Not | Iir_Predefined_Boolean_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_Attribute_Image | Iir_Predefined_Attribute_Value | Iir_Predefined_Attribute_Pos | Iir_Predefined_Attribute_Val | Iir_Predefined_Attribute_Succ | Iir_Predefined_Attribute_Pred | Iir_Predefined_Attribute_Rightof | Iir_Predefined_Attribute_Leftof | Iir_Predefined_Attribute_Left | Iir_Predefined_Attribute_Right | Iir_Predefined_Attribute_Event | Iir_Predefined_Attribute_Active | Iir_Predefined_Attribute_Last_Value | Iir_Predefined_Attribute_Last_Event | Iir_Predefined_Attribute_Last_Active | Iir_Predefined_Attribute_Driving | Iir_Predefined_Attribute_Driving_Value | Iir_Predefined_Array_To_String => -- Not binary or never locally static. 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_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 : String_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 := Start; for I in L + 1 .. Img'Last loop Append (Img (I)); end loop; Finish; return Build_String (Id, Int32 (Img'Last - L), Orig); end Eval_Integer_Image; function Eval_Floating_Image (Val : Iir_Fp64; Orig : Iir) return Iir is use Str_Table; Id : String_Id; -- Sign (1) + digit (1) + dot (1) + digits (15) + exp (1) + sign (1) -- + exp_digits (4) -> 24. Str : String (1 .. 25); P : Natural; V : Iir_Fp64; Vd : Iir_Fp64; Exp : Integer; D : Integer; B : Boolean; Res : Iir; begin -- Handle sign. if Val < 0.0 then Str (1) := '-'; P := 1; V := -Val; else P := 0; V := Val; end if; -- Compute the mantissa. -- FIXME: should do a dichotomy. if V = 0.0 then Exp := 0; elsif V < 1.0 then Exp := -1; while V * (10.0 ** (-Exp)) < 1.0 loop Exp := Exp - 1; end loop; else Exp := 0; while V / (10.0 ** Exp) >= 10.0 loop Exp := Exp + 1; end loop; end if; -- Normalize VAL: in [0; 10[ if Exp >= 0 then V := V / (10.0 ** Exp); else V := V * 10.0 ** (-Exp); end if; for I in 0 .. 15 loop Vd := Iir_Fp64'Truncation (V); P := P + 1; Str (P) := Character'Val (48 + Integer (Vd)); V := (V - Vd) * 10.0; if I = 0 then P := P + 1; Str (P) := '.'; end if; exit when I > 0 and V < 10.0 ** (I + 1 - 15); end loop; if Exp /= 0 then -- LRM93 14.3 -- if the exponent is present, the `e' is written as a lower case -- character. P := P + 1; Str (P) := 'e'; if Exp < 0 then P := P + 1; Str (P) := '-'; Exp := -Exp; end if; B := False; for I in 0 .. 4 loop D := (Exp / 10000) mod 10; if D /= 0 or B or I = 4 then P := P + 1; Str (P) := Character'Val (48 + D); B := True; end if; Exp := (Exp - D * 10000) * 10; end loop; end if; Id := Start; for I in 1 .. P loop Append (Str (I)); end loop; Finish; 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 (Enum, Expr : Iir) return Iir is Name : constant String := Image_Identifier (Enum); Image_Id : constant String_Id := Str_Table.Start; begin for i in Name'range loop Str_Table.Append(Name(i)); end loop; Str_Table.Finish; return Build_String (Image_Id, Nat32(Name'Length), Expr); end Eval_Enumeration_Image; function Build_Enumeration_Value (Val : String; Enum, Expr : Iir) return Iir is Value : String(Val'range); List : constant Iir_List := Get_Enumeration_Literal_List(Enum); begin for i in Val'range loop Value(i) := Ada.Characters.Handling.To_Lower (Val(i)); end loop; for i in 0 .. Get_Nbr_Elements(List) - 1 loop if Value = Image_Identifier(Get_Nth_Element(List, i)) then return Build_Discrete(Iir_Int64(i), Expr); end if; end loop; Error_Msg_Sem ("value """ & Value & """ not in enumeration", Expr); return Null_Iir; end Build_Enumeration_Value; function Eval_Physical_Image (Phys, Expr : Iir) return Iir -- reduces to the base unit (e.g. femtoseconds) is Value : constant String := Iir_Int64'image( Get_Physical_Literal_Value(Phys)); Unit : constant Iir := Get_Primary_Unit (Get_Base_Type (Get_Type(Phys))); UnitName : constant String := Image_Identifier (Unit); Image_Id : constant String_Id := Str_Table.Start; 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(Value(i)); else Length := Length - 1; end if; end loop; Str_Table.Append(' '); for i in UnitName'range loop Str_Table.Append(UnitName(i)); end loop; Str_Table.Finish; return Build_String (Image_Id, Length, Expr); end Eval_Physical_Image; function Build_Physical_Value (Val: String; Phys_Type, Expr: Iir) return Iir is function White (C : in Character) return Boolean is NBSP : constant Character := Character'Val (160); HT : constant Character := Character'Val (9); begin return C = ' ' or C = NBSP or C = HT; end White; UnitName : String(Val'range); Sep : Natural; Found_Unit : Boolean := false; Unit : Iir := Get_Primary_Unit (Phys_Type); 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 White(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) -- 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 Error_Msg_Sem ("Unit """ & UnitName(Sep+1..UnitName'Last) & """ not in physical type", Expr); return Null_Iir; end if; -- FIXME: Should we support real values too? return Build_Physical(Iir_Int64'value(Val(Val'first .. Sep)), Expr); end Build_Physical_Value; 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 => 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); -- 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. if Get_Kind (Get_Type (Res)) = Iir_Kind_Array_Type_Definition then Set_Type (Res, Get_Type (Val)); end if; 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_Image_Attribute => declare Param : Iir; Param_Type : Iir; begin Param := Get_Parameter (Expr); Param := Eval_Static_Expr (Param); Set_Parameter (Expr, Param); 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; Param_Type : Iir; begin Param := Get_Parameter (Expr); Param := Eval_Static_Expr (Param); Set_Parameter (Expr, Param); if Get_Kind (Param) /= Iir_Kind_String_Literal then Error_Msg_Sem ("'value argument not a string", Expr); return Null_Iir; -- or Expr? else -- what type are we converting the string to? Param_Type := Get_Base_Type (Get_Type (Expr)); declare Value : constant String := Image_String_Lit(Param); begin case Get_Kind (Param_Type) is when Iir_Kind_Integer_Type_Definition => return Build_Discrete(Iir_Int64'value(Value), Expr); when Iir_Kind_Enumeration_Type_Definition => return Build_Enumeration_Value (Value, Param_Type, Expr); when Iir_Kind_Floating_Type_Definition => return Build_Floating (Iir_Fp64'value (Value), Expr); when Iir_Kind_Physical_Type_Definition => return Build_Physical_Value (Value, Param_Type, Expr); when others => Error_Kind ("eval_static_expr('value)", Param); end case; end; 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_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 Res := Eval_Expr (Expr); if Res /= Null_Iir and then Get_Type_Staticness (Atype) = Locally and then Get_Kind (Atype) in Iir_Kinds_Range_Type_Definition then 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 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; Any_Dir : Boolean) return Boolean is Type_Range : Iir; begin Type_Range := Get_Range_Constraint (Sub_Type); if not Any_Dir and then 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); exception when Node_Error => -- Avoid error storms. return True; 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 ("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 Iir_Kind_Error => raise Node_Error; 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; function Compare_String_Literals (L, R : Iir) return Compare_Type is type Str_Info is record El : Iir; Ptr : String_Fat_Acc; Len : Nat32; Lit_0 : Iir; Lit_1 : Iir; List : Iir_List; end record; Literal_List : Iir_List; -- Fill Res from EL. This is used to speed up Lt and Eq operations. procedure Get_Info (Expr : Iir; Res : out Str_Info) is begin case Get_Kind (Expr) is when Iir_Kind_Simple_Aggregate => Res := Str_Info'(El => Expr, Ptr => null, Len => 0, Lit_0 | Lit_1 => Null_Iir, List => Get_Simple_Aggregate_List (Expr)); Res.Len := Nat32 (Get_Nbr_Elements (Res.List)); when Iir_Kind_Bit_String_Literal => Res := Str_Info'(El => Expr, Ptr => Get_String_Fat_Acc (Expr), Len => Get_String_Length (Expr), Lit_0 => Get_Bit_String_0 (Expr), Lit_1 => Get_Bit_String_1 (Expr), List => Null_Iir_List); when Iir_Kind_String_Literal => Res := Str_Info'(El => Expr, Ptr => Get_String_Fat_Acc (Expr), Len => Get_String_Length (Expr), Lit_0 | Lit_1 => Null_Iir, List => Null_Iir_List); when others => Error_Kind ("sem_string_choice_range.get_info", Expr); end case; end Get_Info; -- Return the position of element IDX of STR. function Get_Pos (Str : Str_Info; Idx : Nat32) return Iir_Int32 is S : Iir; C : Character; begin case Get_Kind (Str.El) is when Iir_Kind_Simple_Aggregate => S := Get_Nth_Element (Str.List, Natural (Idx)); when Iir_Kind_String_Literal => C := Str.Ptr (Idx + 1); -- FIXME: build a table from character to position. -- This linear search is O(n)! S := Find_Name_In_List (Literal_List, Name_Table.Get_Identifier (C)); when Iir_Kind_Bit_String_Literal => C := Str.Ptr (Idx + 1); case C is when '0' => S := Str.Lit_0; when '1' => S := Str.Lit_1; when others => raise Internal_Error; end case; when others => Error_Kind ("sem_string_choice_range.get_pos", Str.El); end case; return Get_Enum_Pos (S); end Get_Pos; L_Info, R_Info : Str_Info; L_Pos, R_Pos : Iir_Int32; begin Get_Info (L, L_Info); Get_Info (R, R_Info); if L_Info.Len /= R_Info.Len then raise Internal_Error; end if; Literal_List := Get_Enumeration_Literal_List (Get_Base_Type (Get_Element_Subtype (Get_Type (L)))); 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; end Evaluation;