-- Evaluation of static expressions.
-- Copyright (C) 2002, 2003, 2004, 2005 Tristan Gingold
--
-- GHDL is free software; you can redistribute it and/or modify it under
-- the terms of the GNU General Public License as published by the Free
-- Software Foundation; either version 2, or (at your option) any later
-- version.
--
-- GHDL is distributed in the hope that it will be useful, but WITHOUT ANY
-- WARRANTY; without even the implied warranty of MERCHANTABILITY or
-- FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
-- for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with GHDL; see the file COPYING. If not, write to the Free
-- Software Foundation, 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
with Ada.Unchecked_Deallocation;
with 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);
Kind : constant Iir_Kind := Get_Kind (Expr);
Unit : Iir;
begin
case Kind is
when Iir_Kind_Physical_Int_Literal
| Iir_Kind_Physical_Fp_Literal =>
-- Extract Unit.
Unit := Get_Physical_Unit_Value
(Get_Named_Entity (Get_Unit_Name (Expr)));
case Kind is
when Iir_Kind_Physical_Int_Literal =>
return Get_Value (Expr) * Get_Value (Unit);
when Iir_Kind_Physical_Fp_Literal =>
return Iir_Int64
(Get_Fp_Value (Expr) * Iir_Fp64 (Get_Value (Unit)));
when others =>
raise Program_Error;
end case;
when Iir_Kind_Unit_Declaration =>
return Get_Value (Get_Physical_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_Constant (Val : Iir_Index32; Origin : Iir)
return Iir_Enumeration_Literal
is
Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin));
Enum_List : constant Iir_List :=
Get_Enumeration_Literal_List (Enum_Type);
Lit : constant Iir_Enumeration_Literal :=
Get_Nth_Element (Enum_List, Integer (Val));
Res : Iir_Enumeration_Literal;
begin
Res := Copy_Enumeration_Literal (Lit);
Location_Copy (Res, Origin);
Set_Literal_Origin (Res, Origin);
return Res;
end Build_Enumeration_Constant;
function Build_Physical (Val : Iir_Int64; Origin : Iir)
return Iir_Physical_Int_Literal
is
Res : Iir_Physical_Int_Literal;
Unit_Name : Iir;
begin
Res := Create_Iir (Iir_Kind_Physical_Int_Literal);
Location_Copy (Res, Origin);
Unit_Name := Get_Primary_Unit_Name (Get_Base_Type (Get_Type (Origin)));
Set_Unit_Name (Res, Unit_Name);
Set_Value (Res, Val);
Set_Type (Res, Get_Type (Origin));
Set_Literal_Origin (Res, Origin);
Set_Expr_Staticness (Res, Locally);
return Res;
end Build_Physical;
function Build_Discrete (Val : Iir_Int64; Origin : Iir) return Iir is
begin
case Get_Kind (Get_Type (Origin)) is
when Iir_Kind_Enumeration_Type_Definition
| Iir_Kind_Enumeration_Subtype_Definition =>
return Build_Enumeration_Constant (Iir_Index32 (Val), Origin);
when Iir_Kind_Integer_Type_Definition
| Iir_Kind_Integer_Subtype_Definition =>
return Build_Integer (Val, Origin);
when others =>
Error_Kind ("build_discrete", Get_Type (Origin));
end case;
end Build_Discrete;
function Build_String (Val : 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);
Set_Literal_Subtype (Res, Stype);
return Res;
end Build_Simple_Aggregate;
function Build_Overflow (Origin : Iir) return Iir
is
Res : Iir;
begin
Res := Create_Iir (Iir_Kind_Overflow_Literal);
Location_Copy (Res, Origin);
Set_Type (Res, Get_Type (Origin));
Set_Literal_Origin (Res, Origin);
Set_Expr_Staticness (Res, Locally);
return Res;
end Build_Overflow;
function Build_Constant (Val : Iir; Origin : Iir) return Iir
is
Res : Iir;
begin
-- Note: this must work for any literals, because it may be used to
-- replace a locally static constant by its initial value.
case Get_Kind (Val) is
when Iir_Kind_Integer_Literal =>
Res := Create_Iir (Iir_Kind_Integer_Literal);
Set_Value (Res, Get_Value (Val));
when Iir_Kind_Floating_Point_Literal =>
Res := Create_Iir (Iir_Kind_Floating_Point_Literal);
Set_Fp_Value (Res, Get_Fp_Value (Val));
when Iir_Kind_Enumeration_Literal =>
return Build_Enumeration_Constant
(Iir_Index32 (Get_Enum_Pos (Val)), Origin);
when Iir_Kind_Physical_Int_Literal =>
Res := Create_Iir (Iir_Kind_Physical_Int_Literal);
Set_Unit_Name (Res, Get_Primary_Unit_Name
(Get_Base_Type (Get_Type (Origin))));
Set_Value (Res, Get_Physical_Value (Val));
when Iir_Kind_Unit_Declaration =>
Res := Create_Iir (Iir_Kind_Physical_Int_Literal);
Set_Value (Res, Get_Physical_Value (Val));
Set_Unit_Name (Res, Get_Primary_Unit_Name (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));
Set_Literal_Subtype (Res, Get_Type (Origin));
when Iir_Kind_Overflow_Literal =>
Res := Create_Iir (Iir_Kind_Overflow_Literal);
when others =>
Error_Kind ("build_constant", Val);
end case;
Location_Copy (Res, Origin);
Set_Type (Res, Get_Type (Origin));
Set_Literal_Origin (Res, Origin);
Set_Expr_Staticness (Res, Locally);
return Res;
end Build_Constant;
function Build_Boolean (Cond : Boolean) return Iir is
begin
if Cond then
return Boolean_True;
else
return Boolean_False;
end if;
end Build_Boolean;
function Build_Enumeration (Val : Iir_Index32; Origin : Iir)
return Iir_Enumeration_Literal
is
Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin));
Enum_List : constant Iir_List :=
Get_Enumeration_Literal_List (Enum_Type);
begin
return Get_Nth_Element (Enum_List, Integer (Val));
end Build_Enumeration;
function Build_Enumeration (Val : Boolean; Origin : Iir)
return Iir_Enumeration_Literal
is
Enum_Type : constant Iir := Get_Base_Type (Get_Type (Origin));
Enum_List : constant Iir_List :=
Get_Enumeration_Literal_List (Enum_Type);
begin
return Get_Nth_Element (Enum_List, Boolean'Pos (Val));
end Build_Enumeration;
function Build_Constant_Range (Range_Expr : Iir; Origin : Iir) return Iir
is
Res : Iir;
begin
Res := Create_Iir (Iir_Kind_Range_Expression);
Location_Copy (Res, Origin);
Set_Type (Res, Get_Type (Range_Expr));
Set_Left_Limit (Res, Get_Left_Limit (Range_Expr));
Set_Right_Limit (Res, Get_Right_Limit (Range_Expr));
Set_Direction (Res, Get_Direction (Range_Expr));
Set_Range_Origin (Res, Origin);
Set_Expr_Staticness (Res, Locally);
return Res;
end Build_Constant_Range;
function Build_Extreme_Value (Is_Pos : Boolean; Origin : Iir) return Iir
is
Orig_Type : constant Iir := Get_Base_Type (Get_Type (Origin));
begin
case Get_Kind (Orig_Type) is
when Iir_Kind_Integer_Type_Definition =>
if Is_Pos then
return Build_Integer (Iir_Int64'Last, Origin);
else
return Build_Integer (Iir_Int64'First, Origin);
end if;
when others =>
Error_Kind ("build_extreme_value", Orig_Type);
end case;
end Build_Extreme_Value;
-- A_RANGE is a range expression, whose type, location, expr_staticness,
-- left_limit and direction are set.
-- Type of A_RANGE must have a range_constraint.
-- Set the right limit of A_RANGE from LEN.
procedure Set_Right_Limit_By_Length (A_Range : Iir; Len : Iir_Int64)
is
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.
pragma Assert (Get_Type_Staticness (A_Type) = Locally);
Index_Constraint := Get_Range_Constraint (A_Type);
Constraint := Create_Iir (Iir_Kind_Range_Expression);
Set_Location (Constraint, Loc);
Set_Expr_Staticness (Constraint, Locally);
Set_Type (Constraint, A_Type);
Set_Left_Limit (Constraint, Get_Left_Limit (Index_Constraint));
Set_Direction (Constraint, Get_Direction (Index_Constraint));
Set_Right_Limit_By_Length (Constraint, Len);
return Constraint;
end Create_Range_By_Length;
function Create_Range_Subtype_From_Type (A_Type : Iir; Loc : Location_Type)
return Iir
is
Res : Iir;
begin
pragma Assert (Get_Type_Staticness (A_Type) = Locally);
case Get_Kind (A_Type) is
when Iir_Kind_Enumeration_Type_Definition =>
Res := Create_Iir (Iir_Kind_Enumeration_Subtype_Definition);
when Iir_Kind_Integer_Subtype_Definition
| Iir_Kind_Enumeration_Subtype_Definition =>
Res := Create_Iir (Get_Kind (A_Type));
when others =>
Error_Kind ("create_range_subtype_by_length", A_Type);
end case;
Set_Location (Res, Loc);
Set_Base_Type (Res, Get_Base_Type (A_Type));
Set_Type_Staticness (Res, Locally);
return Res;
end Create_Range_Subtype_From_Type;
-- Create a subtype of A_TYPE whose length is LEN.
-- This is used to create subtypes for strings or aggregates.
function Create_Range_Subtype_By_Length
(A_Type : Iir; Len : Iir_Int64; Loc : Location_Type)
return Iir
is
Res : Iir;
begin
Res := Create_Range_Subtype_From_Type (A_Type, Loc);
Set_Range_Constraint (Res, Create_Range_By_Length (A_Type, Len, Loc));
return Res;
end Create_Range_Subtype_By_Length;
function Create_Unidim_Array_From_Index
(Base_Type : Iir; Index_Type : Iir; Loc : Iir)
return Iir_Array_Subtype_Definition
is
Res : Iir_Array_Subtype_Definition;
begin
Res := Create_Array_Subtype (Base_Type, Get_Location (Loc));
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 : constant Iir := Get_Index_Type (Base_Type, 0);
N_Index_Type : Iir;
begin
N_Index_Type := Create_Range_Subtype_By_Length
(Index_Type, Len, Get_Location (Loc));
return Create_Unidim_Array_From_Index (Base_Type, N_Index_Type, Loc);
end Create_Unidim_Array_By_Length;
procedure Free_Eval_Static_Expr (Res : Iir; Orig : Iir) is
begin
if Res /= Orig and then Get_Literal_Origin (Res) = Orig then
Free_Iir (Res);
end if;
end Free_Eval_Static_Expr;
-- Free the result RES of Eval_String_Literal called with ORIG, if created.
procedure Free_Eval_String_Literal (Res : Iir; Orig : Iir)
is
L : Iir_List;
begin
if Res /= Orig then
L := Get_Simple_Aggregate_List (Res);
Destroy_Iir_List (L);
Free_Iir (Res);
end if;
end Free_Eval_String_Literal;
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 : constant Iir := Get_Type (Str);
List : Iir_List;
Lit_0 : constant Iir := Get_Bit_String_0 (Str);
Lit_1 : constant Iir := Get_Bit_String_1 (Str);
begin
List := Create_Iir_List;
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
if Get_Kind (Operand) = Iir_Kind_Overflow_Literal then
-- Propagate overflow.
return Build_Overflow (Orig);
end if;
Func := Get_Implicit_Definition (Get_Implementation (Orig));
case Func is
when Iir_Predefined_Integer_Negation =>
return Build_Integer (-Get_Value (Operand), Orig);
when Iir_Predefined_Integer_Identity =>
return Build_Integer (Get_Value (Operand), Orig);
when Iir_Predefined_Integer_Absolute =>
return Build_Integer (abs Get_Value (Operand), Orig);
when Iir_Predefined_Floating_Negation =>
return Build_Floating (-Get_Fp_Value (Operand), Orig);
when Iir_Predefined_Floating_Identity =>
return Build_Floating (Get_Fp_Value (Operand), Orig);
when Iir_Predefined_Floating_Absolute =>
return Build_Floating (abs Get_Fp_Value (Operand), Orig);
when Iir_Predefined_Physical_Negation =>
return Build_Physical (-Get_Physical_Value (Operand), Orig);
when Iir_Predefined_Physical_Identity =>
return Build_Physical (Get_Physical_Value (Operand), Orig);
when Iir_Predefined_Physical_Absolute =>
return Build_Physical (abs Get_Physical_Value (Operand), Orig);
when Iir_Predefined_Boolean_Not
| Iir_Predefined_Bit_Not =>
return Build_Enumeration (Get_Enum_Pos (Operand) = 0, Orig);
when Iir_Predefined_TF_Array_Not =>
declare
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 =>
-- Can happen for absolute.
Warning_Msg_Sem ("arithmetic overflow in static expression", Orig);
return Build_Overflow (Orig);
end Eval_Monadic_Operator;
function Eval_Dyadic_Bit_Array_Operator
(Expr : Iir;
Left, Right : Iir;
Func : Iir_Predefined_Dyadic_TF_Array_Functions)
return Iir
is
use Str_Table;
L_Str : constant String_Fat_Acc := Get_String_Fat_Acc (Left);
R_Str : constant String_Fat_Acc := Get_String_Fat_Acc (Right);
Len : Nat32;
Id : String_Id;
Res : Iir;
begin
Len := Get_String_Length (Left);
if Len /= Get_String_Length (Right) then
Warning_Msg_Sem ("length of left and right operands mismatch", Expr);
return Build_Overflow (Expr);
else
Id := Start;
case Func is
when Iir_Predefined_TF_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_TF_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_TF_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_TF_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_TF_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;
Res := Build_String (Id, Len, Expr);
-- The unconstrained type is replaced by the constrained one.
Set_Type (Res, Get_Type (Left));
return Res;
end if;
end Eval_Dyadic_Bit_Array_Operator;
-- Return TRUE if VAL /= 0.
function Check_Integer_Division_By_Zero (Expr : Iir; Val : Iir)
return Boolean
is
begin
if Get_Value (Val) = 0 then
Warning_Msg_Sem ("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) mod Len;
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_Aggr, Right_Aggr : Iir;
Left_List, Right_List : Iir_List;
Left_Len : Natural;
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);
Left_Len := 1;
when Iir_Predefined_Array_Element_Concat
| Iir_Predefined_Array_Array_Concat =>
Left_Aggr := Eval_String_Literal (Left);
Left_List := Get_Simple_Aggregate_List (Left_Aggr);
Left_Len := Get_Nbr_Elements (Left_List);
for I in 0 .. Left_Len - 1 loop
Append_Element (Res_List, Get_Nth_Element (Left_List, I));
end loop;
Free_Eval_String_Literal (Left_Aggr, Left);
end case;
-- Right:
case Func is
when Iir_Predefined_Array_Element_Concat
| Iir_Predefined_Element_Element_Concat =>
Append_Element (Res_List, Right);
when Iir_Predefined_Element_Array_Concat
| Iir_Predefined_Array_Array_Concat =>
Right_Aggr := Eval_String_Literal (Right);
Right_List := Get_Simple_Aggregate_List (Right_Aggr);
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;
Free_Eval_String_Literal (Right_Aggr, Right);
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 Left_Len = 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
Left_Index : constant Iir :=
Get_Index_Type (Get_Type (Left), 0);
Left_Range : constant Iir :=
Get_Range_Constraint (Left_Index);
Ret_Type : constant Iir :=
Get_Return_Type (Get_Implementation (Orig));
A_Range : Iir;
Index_Type : Iir;
begin
A_Range := Create_Iir (Iir_Kind_Range_Expression);
Set_Type (A_Range, Get_Index_Type (Ret_Type, 0));
Set_Expr_Staticness (A_Range, Locally);
Set_Left_Limit (A_Range, Get_Left_Limit (Left_Range));
Set_Direction (A_Range, Get_Direction (Left_Range));
Location_Copy (A_Range, Orig);
Set_Right_Limit_By_Length (A_Range, Iir_Int64 (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
Left_Val, Right_Val : Iir;
L_List : Iir_List;
R_List : Iir_List;
N : Natural;
Res : Boolean;
begin
Left_Val := Eval_String_Literal (Left);
Right_Val := Eval_String_Literal (Right);
L_List := Get_Simple_Aggregate_List (Left_Val);
R_List := Get_Simple_Aggregate_List (Right_Val);
N := Get_Nbr_Elements (L_List);
if N /= Get_Nbr_Elements (R_List) then
-- Cannot be equal if not the same length.
Res := False;
else
Res := 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
Res := False;
exit;
end if;
end loop;
end if;
Free_Eval_Static_Expr (Left_Val, Left);
Free_Eval_Static_Expr (Right_Val, Right);
return Res;
end Eval_Array_Equality;
-- ORIG is either a dyadic operator or a function call.
function Eval_Dyadic_Operator (Orig : Iir; Imp : Iir; Left, Right : Iir)
return Iir
is
pragma Unsuppress (Overflow_Check);
Func : constant Iir_Predefined_Functions :=
Get_Implicit_Definition (Imp);
begin
if Get_Kind (Left) = Iir_Kind_Overflow_Literal
or else Get_Kind (Right) = Iir_Kind_Overflow_Literal
then
return Build_Overflow (Orig);
end if;
case Func is
when Iir_Predefined_Integer_Plus =>
return Build_Integer (Get_Value (Left) + Get_Value (Right), Orig);
when Iir_Predefined_Integer_Minus =>
return Build_Integer (Get_Value (Left) - Get_Value (Right), Orig);
when Iir_Predefined_Integer_Mul =>
return Build_Integer (Get_Value (Left) * Get_Value (Right), Orig);
when Iir_Predefined_Integer_Div =>
if Check_Integer_Division_By_Zero (Orig, Right) then
return Build_Integer
(Get_Value (Left) / Get_Value (Right), Orig);
else
return Build_Overflow (Orig);
end if;
when Iir_Predefined_Integer_Mod =>
if Check_Integer_Division_By_Zero (Orig, Right) then
return Build_Integer
(Get_Value (Left) mod Get_Value (Right), Orig);
else
return Build_Overflow (Orig);
end if;
when Iir_Predefined_Integer_Rem =>
if Check_Integer_Division_By_Zero (Orig, Right) then
return Build_Integer
(Get_Value (Left) rem Get_Value (Right), Orig);
else
return Build_Overflow (Orig);
end if;
when Iir_Predefined_Integer_Exp =>
return Build_Integer
(Get_Value (Left) ** Integer (Get_Value (Right)), Orig);
when Iir_Predefined_Integer_Equality =>
return Build_Boolean (Get_Value (Left) = Get_Value (Right));
when Iir_Predefined_Integer_Inequality =>
return Build_Boolean (Get_Value (Left) /= Get_Value (Right));
when Iir_Predefined_Integer_Greater_Equal =>
return Build_Boolean (Get_Value (Left) >= Get_Value (Right));
when Iir_Predefined_Integer_Greater =>
return Build_Boolean (Get_Value (Left) > Get_Value (Right));
when Iir_Predefined_Integer_Less_Equal =>
return Build_Boolean (Get_Value (Left) <= Get_Value (Right));
when Iir_Predefined_Integer_Less =>
return Build_Boolean (Get_Value (Left) < Get_Value (Right));
when Iir_Predefined_Integer_Minimum =>
if Get_Value (Left) < Get_Value (Right) then
return Left;
else
return Right;
end if;
when Iir_Predefined_Integer_Maximum =>
if Get_Value (Left) > Get_Value (Right) then
return Left;
else
return Right;
end if;
when Iir_Predefined_Floating_Equality =>
return Build_Boolean (Get_Fp_Value (Left) = Get_Fp_Value (Right));
when Iir_Predefined_Floating_Inequality =>
return Build_Boolean (Get_Fp_Value (Left) /= Get_Fp_Value (Right));
when Iir_Predefined_Floating_Greater =>
return Build_Boolean (Get_Fp_Value (Left) > Get_Fp_Value (Right));
when Iir_Predefined_Floating_Greater_Equal =>
return Build_Boolean (Get_Fp_Value (Left) >= Get_Fp_Value (Right));
when Iir_Predefined_Floating_Less =>
return Build_Boolean (Get_Fp_Value (Left) < Get_Fp_Value (Right));
when Iir_Predefined_Floating_Less_Equal =>
return Build_Boolean (Get_Fp_Value (Left) <= Get_Fp_Value (Right));
when Iir_Predefined_Floating_Minus =>
return Build_Floating
(Get_Fp_Value (Left) - Get_Fp_Value (Right), Orig);
when Iir_Predefined_Floating_Plus =>
return Build_Floating
(Get_Fp_Value (Left) + Get_Fp_Value (Right), Orig);
when Iir_Predefined_Floating_Mul =>
return Build_Floating
(Get_Fp_Value (Left) * Get_Fp_Value (Right), Orig);
when Iir_Predefined_Floating_Div =>
if Get_Fp_Value (Right) = 0.0 then
Warning_Msg_Sem ("right operand of division is 0", Orig);
return Build_Overflow (Orig);
else
return Build_Floating
(Get_Fp_Value (Left) / Get_Fp_Value (Right), Orig);
end if;
when Iir_Predefined_Floating_Exp =>
declare
Exp : Iir_Int64;
Res : Iir_Fp64;
Val : Iir_Fp64;
begin
Res := 1.0;
Val := Get_Fp_Value (Left);
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_Floating_Minimum =>
if Get_Fp_Value (Left) < Get_Fp_Value (Right) then
return Left;
else
return Right;
end if;
when Iir_Predefined_Floating_Maximum =>
if Get_Fp_Value (Left) > Get_Fp_Value (Right) then
return Left;
else
return Right;
end if;
when Iir_Predefined_Physical_Equality =>
return Build_Boolean
(Get_Physical_Value (Left) = Get_Physical_Value (Right));
when Iir_Predefined_Physical_Inequality =>
return Build_Boolean
(Get_Physical_Value (Left) /= Get_Physical_Value (Right));
when Iir_Predefined_Physical_Greater_Equal =>
return Build_Boolean
(Get_Physical_Value (Left) >= Get_Physical_Value (Right));
when Iir_Predefined_Physical_Greater =>
return Build_Boolean
(Get_Physical_Value (Left) > Get_Physical_Value (Right));
when Iir_Predefined_Physical_Less_Equal =>
return Build_Boolean
(Get_Physical_Value (Left) <= Get_Physical_Value (Right));
when Iir_Predefined_Physical_Less =>
return Build_Boolean
(Get_Physical_Value (Left) < Get_Physical_Value (Right));
when Iir_Predefined_Physical_Physical_Div =>
return Build_Integer
(Get_Physical_Value (Left) / Get_Physical_Value (Right), Orig);
when Iir_Predefined_Physical_Integer_Div =>
return Build_Physical
(Get_Physical_Value (Left) / Get_Value (Right), Orig);
when Iir_Predefined_Physical_Minus =>
return Build_Physical
(Get_Physical_Value (Left) - Get_Physical_Value (Right), Orig);
when Iir_Predefined_Physical_Plus =>
return Build_Physical
(Get_Physical_Value (Left) + Get_Physical_Value (Right), Orig);
when Iir_Predefined_Integer_Physical_Mul =>
return Build_Physical
(Get_Value (Left) * Get_Physical_Value (Right), Orig);
when Iir_Predefined_Physical_Integer_Mul =>
return Build_Physical
(Get_Physical_Value (Left) * Get_Value (Right), Orig);
when Iir_Predefined_Real_Physical_Mul =>
-- FIXME: overflow??
return Build_Physical
(Iir_Int64 (Get_Fp_Value (Left)
* Iir_Fp64 (Get_Physical_Value (Right))), Orig);
when Iir_Predefined_Physical_Real_Mul =>
-- FIXME: overflow??
return Build_Physical
(Iir_Int64 (Iir_Fp64 (Get_Physical_Value (Left))
* Get_Fp_Value (Right)), Orig);
when Iir_Predefined_Physical_Real_Div =>
-- FIXME: overflow??
return Build_Physical
(Iir_Int64 (Iir_Fp64 (Get_Physical_Value (Left))
/ Get_Fp_Value (Right)), Orig);
when Iir_Predefined_Physical_Minimum =>
return Build_Physical (Iir_Int64'Min (Get_Physical_Value (Left),
Get_Physical_Value (Right)),
Orig);
when Iir_Predefined_Physical_Maximum =>
return Build_Physical (Iir_Int64'Max (Get_Physical_Value (Left),
Get_Physical_Value (Right)),
Orig);
when Iir_Predefined_Element_Array_Concat
| Iir_Predefined_Array_Element_Concat
| Iir_Predefined_Array_Array_Concat
| Iir_Predefined_Element_Element_Concat =>
return Eval_Concatenation (Left, Right, Orig, Func);
when Iir_Predefined_Enum_Equality
| Iir_Predefined_Bit_Match_Equality =>
return Build_Enumeration
(Get_Enum_Pos (Left) = Get_Enum_Pos (Right), Orig);
when Iir_Predefined_Enum_Inequality
| Iir_Predefined_Bit_Match_Inequality =>
return Build_Enumeration
(Get_Enum_Pos (Left) /= Get_Enum_Pos (Right), Orig);
when Iir_Predefined_Enum_Greater_Equal
| Iir_Predefined_Bit_Match_Greater_Equal =>
return Build_Enumeration
(Get_Enum_Pos (Left) >= Get_Enum_Pos (Right), Orig);
when Iir_Predefined_Enum_Greater
| Iir_Predefined_Bit_Match_Greater =>
return Build_Enumeration
(Get_Enum_Pos (Left) > Get_Enum_Pos (Right), Orig);
when Iir_Predefined_Enum_Less_Equal
| Iir_Predefined_Bit_Match_Less_Equal =>
return Build_Enumeration
(Get_Enum_Pos (Left) <= Get_Enum_Pos (Right), Orig);
when Iir_Predefined_Enum_Less
| Iir_Predefined_Bit_Match_Less =>
return Build_Enumeration
(Get_Enum_Pos (Left) < Get_Enum_Pos (Right), Orig);
when Iir_Predefined_Enum_Minimum =>
if Get_Enum_Pos (Left) < Get_Enum_Pos (Right) then
return Left;
else
return Right;
end if;
when Iir_Predefined_Enum_Maximum =>
if Get_Enum_Pos (Left) > Get_Enum_Pos (Right) then
return Left;
else
return Right;
end if;
when Iir_Predefined_Boolean_And
| Iir_Predefined_Bit_And =>
return Build_Enumeration
(Get_Enum_Pos (Left) = 1 and Get_Enum_Pos (Right) = 1, Orig);
when Iir_Predefined_Boolean_Nand
| Iir_Predefined_Bit_Nand =>
return Build_Enumeration
(not (Get_Enum_Pos (Left) = 1 and Get_Enum_Pos (Right) = 1),
Orig);
when Iir_Predefined_Boolean_Or
| Iir_Predefined_Bit_Or =>
return Build_Enumeration
(Get_Enum_Pos (Left) = 1 or Get_Enum_Pos (Right) = 1, Orig);
when Iir_Predefined_Boolean_Nor
| Iir_Predefined_Bit_Nor =>
return Build_Enumeration
(not (Get_Enum_Pos (Left) = 1 or Get_Enum_Pos (Right) = 1),
Orig);
when Iir_Predefined_Boolean_Xor
| Iir_Predefined_Bit_Xor =>
return Build_Enumeration
(Get_Enum_Pos (Left) = 1 xor Get_Enum_Pos (Right) = 1, Orig);
when Iir_Predefined_Boolean_Xnor
| Iir_Predefined_Bit_Xnor =>
return Build_Enumeration
(not (Get_Enum_Pos (Left) = 1 xor Get_Enum_Pos (Right) = 1),
Orig);
when Iir_Predefined_Dyadic_TF_Array_Functions =>
-- FIXME: only for bit ?
return Eval_Dyadic_Bit_Array_Operator (Orig, Left, Right, Func);
when Iir_Predefined_Universal_R_I_Mul =>
return Build_Floating
(Get_Fp_Value (Left) * Iir_Fp64 (Get_Value (Right)), Orig);
when Iir_Predefined_Universal_I_R_Mul =>
return Build_Floating
(Iir_Fp64 (Get_Value (Left)) * Get_Fp_Value (Right), Orig);
when Iir_Predefined_Universal_R_I_Div =>
return Build_Floating
(Get_Fp_Value (Left) / Iir_Fp64 (Get_Value (Right)), Orig);
when Iir_Predefined_Array_Equality =>
return Build_Boolean (Eval_Array_Equality (Left, Right));
when Iir_Predefined_Array_Inequality =>
return Build_Boolean (not Eval_Array_Equality (Left, Right));
when Iir_Predefined_Array_Sll
| Iir_Predefined_Array_Srl
| Iir_Predefined_Array_Sla
| Iir_Predefined_Array_Sra
| Iir_Predefined_Array_Rol
| Iir_Predefined_Array_Ror =>
declare
Left_Aggr : Iir;
Res : Iir;
begin
Left_Aggr := Eval_String_Literal (Left);
Res := Eval_Shift_Operator (Left_Aggr, Right, Orig, Func);
Free_Eval_String_Literal (Left_Aggr, Left);
return Res;
end;
when Iir_Predefined_Array_Less
| Iir_Predefined_Array_Less_Equal
| Iir_Predefined_Array_Greater
| Iir_Predefined_Array_Greater_Equal =>
-- FIXME: todo.
Error_Internal (Orig, "eval_dyadic_operator: " &
Iir_Predefined_Functions'Image (Func));
when Iir_Predefined_Boolean_Not
| Iir_Predefined_Boolean_Rising_Edge
| Iir_Predefined_Boolean_Falling_Edge
| Iir_Predefined_Bit_Not
| Iir_Predefined_Bit_Rising_Edge
| Iir_Predefined_Bit_Falling_Edge
| Iir_Predefined_Integer_Absolute
| Iir_Predefined_Integer_Identity
| Iir_Predefined_Integer_Negation
| Iir_Predefined_Floating_Absolute
| Iir_Predefined_Floating_Negation
| Iir_Predefined_Floating_Identity
| Iir_Predefined_Physical_Absolute
| Iir_Predefined_Physical_Identity
| Iir_Predefined_Physical_Negation
| Iir_Predefined_Error
| Iir_Predefined_Record_Equality
| Iir_Predefined_Record_Inequality
| Iir_Predefined_Access_Equality
| Iir_Predefined_Access_Inequality
| Iir_Predefined_TF_Array_Not
| Iir_Predefined_Now_Function
| Iir_Predefined_Deallocate
| Iir_Predefined_Write
| Iir_Predefined_Read
| Iir_Predefined_Read_Length
| Iir_Predefined_Flush
| Iir_Predefined_File_Open
| Iir_Predefined_File_Open_Status
| Iir_Predefined_File_Close
| Iir_Predefined_Endfile
| Iir_Predefined_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_Char_To_String
| Iir_Predefined_Bit_Vector_To_Ostring
| Iir_Predefined_Bit_Vector_To_Hstring =>
-- Not binary or never locally static.
Error_Internal (Orig, "eval_dyadic_operator: " &
Iir_Predefined_Functions'Image (Func));
when Iir_Predefined_Bit_Condition =>
raise Internal_Error;
when Iir_Predefined_Array_Minimum
| Iir_Predefined_Array_Maximum
| Iir_Predefined_Vector_Minimum
| Iir_Predefined_Vector_Maximum =>
raise Internal_Error;
when Iir_Predefined_Std_Ulogic_Match_Equality
| Iir_Predefined_Std_Ulogic_Match_Inequality
| Iir_Predefined_Std_Ulogic_Match_Less
| Iir_Predefined_Std_Ulogic_Match_Less_Equal
| Iir_Predefined_Std_Ulogic_Match_Greater
| Iir_Predefined_Std_Ulogic_Match_Greater_Equal =>
-- TODO
raise Internal_Error;
when Iir_Predefined_Enum_To_String
| Iir_Predefined_Integer_To_String
| Iir_Predefined_Floating_To_String
| Iir_Predefined_Real_To_String_Digits
| Iir_Predefined_Real_To_String_Format
| Iir_Predefined_Physical_To_String
| Iir_Predefined_Time_To_String_Unit =>
-- TODO
raise Internal_Error;
when Iir_Predefined_TF_Array_Element_And
| Iir_Predefined_TF_Element_Array_And
| Iir_Predefined_TF_Array_Element_Or
| Iir_Predefined_TF_Element_Array_Or
| Iir_Predefined_TF_Array_Element_Nand
| Iir_Predefined_TF_Element_Array_Nand
| Iir_Predefined_TF_Array_Element_Nor
| Iir_Predefined_TF_Element_Array_Nor
| Iir_Predefined_TF_Array_Element_Xor
| Iir_Predefined_TF_Element_Array_Xor
| Iir_Predefined_TF_Array_Element_Xnor
| Iir_Predefined_TF_Element_Array_Xnor =>
-- TODO
raise Internal_Error;
when Iir_Predefined_TF_Reduction_And
| Iir_Predefined_TF_Reduction_Or
| Iir_Predefined_TF_Reduction_Nand
| Iir_Predefined_TF_Reduction_Nor
| Iir_Predefined_TF_Reduction_Xor
| Iir_Predefined_TF_Reduction_Xnor
| Iir_Predefined_TF_Reduction_Not =>
-- TODO
raise Internal_Error;
when Iir_Predefined_Bit_Array_Match_Equality
| Iir_Predefined_Bit_Array_Match_Inequality
| Iir_Predefined_Std_Ulogic_Array_Match_Equality
| Iir_Predefined_Std_Ulogic_Array_Match_Inequality =>
-- TODO
raise Internal_Error;
end case;
exception
when Constraint_Error =>
Warning_Msg_Sem ("arithmetic overflow in static expression", Orig);
return Build_Overflow (Orig);
end Eval_Dyadic_Operator;
-- Evaluate any array attribute, return the type for the prefix.
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 -- FIXME: remove
| Iir_Kind_Selected_Element
| Iir_Kind_Indexed_Name
| Iir_Kind_Slice_Name
| Iir_Kind_Subtype_Declaration
| Iir_Kind_Type_Declaration
| Iir_Kind_Implicit_Dereference =>
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 Iir_Kinds_Denoting_Name =>
Prefix_Type := Get_Type (Prefix);
when others =>
Error_Kind ("eval_array_attribute", Prefix);
end case;
if Get_Kind (Prefix_Type) /= Iir_Kind_Array_Subtype_Definition then
Error_Kind ("eval_array_attribute(2)", Prefix_Type);
end if;
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_Enumeration (Iir_Index32 (I), Expr);
end if;
end loop;
Warning_Msg_Sem ("value """ & Value & """ not in enumeration", Expr);
return Build_Overflow (Expr);
end Build_Enumeration_Value;
function Eval_Physical_Image (Phys, Expr: Iir) return Iir
is
-- Reduces to the base unit (e.g. femtoseconds).
Value : constant String := Iir_Int64'Image (Get_Physical_Value (Phys));
Unit : constant Iir :=
Get_Primary_Unit (Get_Base_Type (Get_Type (Phys)));
UnitName : constant String := Image_Identifier (Unit);
Image_Id : constant 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);
Mult : Iir_Int64;
Sep : Natural;
Found_Unit : Boolean := false;
Found_Real : 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)
for I in Val'First .. Sep loop
if Val (I) = '.' then
Found_Real := true;
end if;
end loop;
-- Chain down the units looking for matching one
Unit := Get_Primary_Unit (Phys_Type);
while Unit /= Null_Iir loop
exit when (UnitName (Sep + 1 .. UnitName'Last)
= Image_Identifier (Unit));
Unit := Get_Chain (Unit);
end loop;
if Unit = Null_Iir then
Warning_Msg_Sem ("Unit """ & UnitName (Sep + 1 .. UnitName'Last)
& """ not in physical type", Expr);
return Build_Overflow (Expr);
end if;
Mult := Get_Value (Get_Physical_Unit_Value (Unit));
if Found_Real then
return Build_Physical
(Iir_Int64 (Iir_Fp64'Value (Val (Val'First .. Sep))
* Iir_Fp64 (Mult)),
Expr);
else
return Build_Physical
(Iir_Int64'Value (Val (Val'First .. Sep)) * Mult, Expr);
end if;
end Build_Physical_Value;
function Eval_Incdec (Expr : Iir; N : Iir_Int64; Origin : Iir) return Iir
is
P : Iir_Int64;
begin
case Get_Kind (Expr) is
when Iir_Kind_Integer_Literal =>
return Build_Integer (Get_Value (Expr) + N, Origin);
when Iir_Kind_Enumeration_Literal =>
P := Iir_Int64 (Get_Enum_Pos (Expr)) + N;
if P < 0 then
Warning_Msg_Sem ("static constant violates bounds", Expr);
return Build_Overflow (Origin);
else
return Build_Enumeration (Iir_Index32 (P), Origin);
end if;
when Iir_Kind_Physical_Int_Literal
| Iir_Kind_Unit_Declaration =>
return Build_Physical (Get_Physical_Value (Expr) + N, Origin);
when others =>
Error_Kind ("eval_incdec", Expr);
end case;
end Eval_Incdec;
function Convert_Range (Rng : Iir; Res_Type : Iir; Loc : Iir) return Iir
is
Res_Btype : Iir;
function Create_Bound (Val : Iir) return Iir
is
R : Iir;
begin
R := Create_Iir (Iir_Kind_Integer_Literal);
Location_Copy (R, Loc);
Set_Value (R, Get_Value (Val));
Set_Type (R, Res_Btype);
Set_Expr_Staticness (R, Locally);
return R;
end Create_Bound;
Res : Iir;
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 : constant Iir := Get_Type (Conv);
Val_Type : constant Iir := Get_Type (Val);
Conv_Index_Type : constant Iir := Get_Index_Type (Conv_Type, 0);
Val_Index_Type : constant Iir := Get_Index_Type (Val_Type, 0);
Index_Type : Iir;
Res_Type : Iir;
Res : Iir;
Rng : Iir;
begin
-- The expression is either a simple aggregate or a (bit) string.
Res := Build_Constant (Val, Conv);
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
Warning_Msg_Sem
("non matching length in type conversion", Conv);
return Build_Overflow (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;
Res_Type := Create_Unidim_Array_From_Index
(Get_Base_Type (Conv_Type), Index_Type, Conv);
Set_Type (Res, Res_Type);
Set_Type_Conversion_Subtype (Conv, Res_Type);
return Res;
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_Static_Expr (Get_Expression (Expr));
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_Physical_Literal (Expr : Iir) return Iir
is
Val : Iir;
begin
case Get_Kind (Expr) is
when Iir_Kind_Physical_Fp_Literal =>
Val := Expr;
when Iir_Kind_Physical_Int_Literal =>
if Get_Named_Entity (Get_Unit_Name (Expr))
= Get_Primary_Unit (Get_Base_Type (Get_Type (Expr)))
then
return Expr;
else
Val := Expr;
end if;
when Iir_Kind_Unit_Declaration =>
Val := Expr;
when Iir_Kinds_Denoting_Name =>
Val := Get_Named_Entity (Expr);
pragma Assert (Get_Kind (Val) = Iir_Kind_Unit_Declaration);
when others =>
Error_Kind ("eval_physical_literal", Expr);
end case;
return Build_Physical (Get_Physical_Value (Val), Expr);
end Eval_Physical_Literal;
function Eval_Static_Expr (Expr: Iir) return Iir
is
Res : Iir;
Val : Iir;
begin
case Get_Kind (Expr) is
when Iir_Kinds_Denoting_Name =>
return Eval_Static_Expr (Get_Named_Entity (Expr));
when Iir_Kind_Integer_Literal
| Iir_Kind_Enumeration_Literal
| Iir_Kind_Floating_Point_Literal
| Iir_Kind_String_Literal
| Iir_Kind_Bit_String_Literal
| Iir_Kind_Overflow_Literal
| Iir_Kind_Physical_Int_Literal
| Iir_Kind_Physical_Fp_Literal =>
return Expr;
when Iir_Kind_Constant_Declaration =>
Val := Eval_Static_Expr (Get_Default_Value (Expr));
-- Type of the expression should be type of the constant
-- declaration at least in case of array subtype.
-- If the constant is declared as an unconstrained array, get type
-- from the default value.
-- FIXME: handle this during semantisation of the declaration:
-- add an implicit subtype conversion node ?
-- FIXME: this currently creates a node at each evalation.
if Get_Kind (Get_Type (Val)) = Iir_Kind_Array_Type_Definition then
Res := Build_Constant (Val, Expr);
Set_Type (Res, Get_Type (Val));
return Res;
else
return Val;
end if;
when Iir_Kind_Object_Alias_Declaration =>
return Eval_Static_Expr (Get_Name (Expr));
when Iir_Kind_Unit_Declaration =>
return Get_Physical_Unit_Value (Expr);
when Iir_Kind_Simple_Aggregate =>
return Expr;
when Iir_Kind_Parenthesis_Expression =>
return Eval_Static_Expr (Get_Expression (Expr));
when Iir_Kind_Qualified_Expression =>
return Eval_Static_Expr (Get_Expression (Expr));
when Iir_Kind_Type_Conversion =>
return Eval_Type_Conversion (Expr);
when Iir_Kinds_Monadic_Operator =>
declare
Operand : Iir;
begin
Operand := Eval_Static_Expr (Get_Operand (Expr));
return Eval_Monadic_Operator (Expr, Operand);
end;
when Iir_Kinds_Dyadic_Operator =>
declare
Left : constant Iir := Get_Left (Expr);
Right : constant Iir := Get_Right (Expr);
Left_Val, Right_Val : Iir;
Res : Iir;
begin
Left_Val := Eval_Static_Expr (Left);
Right_Val := Eval_Static_Expr (Right);
Res := Eval_Dyadic_Operator
(Expr, Get_Implementation (Expr), Left_Val, Right_Val);
Free_Eval_Static_Expr (Left_Val, Left);
Free_Eval_Static_Expr (Right_Val, Right);
return Res;
end;
when Iir_Kind_Attribute_Name =>
-- An attribute name designates an attribute value.
declare
Attr_Val : constant Iir := Get_Named_Entity (Expr);
Attr_Expr : constant Iir :=
Get_Expression (Get_Attribute_Specification (Attr_Val));
Val : Iir;
begin
Val := Eval_Static_Expr (Attr_Expr);
-- FIXME: see constant_declaration.
-- Currently, this avoids weird nodes, such as a string literal
-- whose type is an unconstrained array type.
Res := Build_Constant (Val, Expr);
Set_Type (Res, Get_Type (Val));
return Res;
end;
when Iir_Kind_Pos_Attribute =>
declare
Param : constant Iir := Get_Parameter (Expr);
Val : Iir;
Res : Iir;
begin
Val := Eval_Static_Expr (Param);
-- FIXME: check bounds, handle overflow.
Res := Build_Integer (Eval_Pos (Val), Expr);
Free_Eval_Static_Expr (Val, Param);
return Res;
end;
when Iir_Kind_Val_Attribute =>
declare
Expr_Type : constant Iir := Get_Type (Expr);
Val_Expr : Iir;
Val : Iir_Int64;
begin
Val_Expr := Eval_Static_Expr (Get_Parameter (Expr));
Val := Eval_Pos (Val_Expr);
-- Note: the type of 'val is a base type.
-- FIXME: handle VHDL93 restrictions.
if Get_Kind (Expr_Type) = Iir_Kind_Enumeration_Type_Definition
and then
not Eval_Int_In_Range (Val, Get_Range_Constraint (Expr_Type))
then
Warning_Msg_Sem
("static argument out of the type range", Expr);
return Build_Overflow (Expr);
end if;
if Get_Kind (Get_Base_Type (Get_Type (Expr)))
= Iir_Kind_Physical_Type_Definition
then
return Build_Physical (Val, Expr);
else
return Build_Discrete (Val, Expr);
end if;
end;
when Iir_Kind_Image_Attribute =>
declare
Param : Iir;
Param_Type : Iir;
begin
Param := Get_Parameter (Expr);
Param := Eval_Static_Expr (Param);
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
-- FIXME: Isn't it an implementation restriction.
Warning_Msg_Sem ("'value argument not a string", Expr);
return Build_Overflow (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 Eval_Static_Expr
(Get_Left_Limit (Eval_Static_Range (Get_Prefix (Expr))));
when Iir_Kind_Right_Type_Attribute =>
return Eval_Static_Expr
(Get_Right_Limit (Eval_Static_Range (Get_Prefix (Expr))));
when Iir_Kind_High_Type_Attribute =>
return Eval_Static_Expr
(Get_High_Limit (Eval_Static_Range (Get_Prefix (Expr))));
when Iir_Kind_Low_Type_Attribute =>
return Eval_Static_Expr
(Get_Low_Limit (Eval_Static_Range (Get_Prefix (Expr))));
when Iir_Kind_Ascending_Type_Attribute =>
return Build_Boolean
(Get_Direction (Eval_Static_Range (Get_Prefix (Expr))) = Iir_To);
when Iir_Kind_Length_Array_Attribute =>
declare
Index : Iir;
begin
Index := Eval_Array_Attribute (Expr);
return Build_Discrete (Eval_Discrete_Type_Length (Index), Expr);
end;
when Iir_Kind_Left_Array_Attribute =>
declare
Index : Iir;
begin
Index := Eval_Array_Attribute (Expr);
return Eval_Static_Expr
(Get_Left_Limit (Get_Range_Constraint (Index)));
end;
when Iir_Kind_Right_Array_Attribute =>
declare
Index : Iir;
begin
Index := Eval_Array_Attribute (Expr);
return Eval_Static_Expr
(Get_Right_Limit (Get_Range_Constraint (Index)));
end;
when Iir_Kind_Low_Array_Attribute =>
declare
Index : Iir;
begin
Index := Eval_Array_Attribute (Expr);
return Eval_Static_Expr
(Get_Low_Limit (Get_Range_Constraint (Index)));
end;
when Iir_Kind_High_Array_Attribute =>
declare
Index : Iir;
begin
Index := Eval_Array_Attribute (Expr);
return Eval_Static_Expr
(Get_High_Limit (Get_Range_Constraint (Index)));
end;
when Iir_Kind_Ascending_Array_Attribute =>
declare
Index : Iir;
begin
Index := Eval_Array_Attribute (Expr);
return Build_Boolean
(Get_Direction (Get_Range_Constraint (Index)) = Iir_To);
end;
when Iir_Kind_Pred_Attribute =>
Res := Eval_Incdec
(Eval_Static_Expr (Get_Parameter (Expr)), -1, Expr);
Eval_Check_Bound (Res, Get_Type (Get_Prefix (Expr)));
return Res;
when Iir_Kind_Succ_Attribute =>
Res := Eval_Incdec
(Eval_Static_Expr (Get_Parameter (Expr)), +1, Expr);
Eval_Check_Bound (Res, Get_Type (Get_Prefix (Expr)));
return Res;
when Iir_Kind_Leftof_Attribute
| Iir_Kind_Rightof_Attribute =>
declare
Rng : Iir;
N : Iir_Int64;
Prefix_Type : Iir;
Res : Iir;
begin
Prefix_Type := Get_Type (Get_Prefix (Expr));
Rng := Eval_Static_Range (Prefix_Type);
case Get_Direction (Rng) is
when Iir_To =>
N := 1;
when Iir_Downto =>
N := -1;
end case;
case Get_Kind (Expr) is
when Iir_Kind_Leftof_Attribute =>
N := -N;
when Iir_Kind_Rightof_Attribute =>
null;
when others =>
raise Internal_Error;
end case;
Res := Eval_Incdec
(Eval_Static_Expr (Get_Parameter (Expr)), N, Expr);
Eval_Check_Bound (Res, Prefix_Type);
return Res;
end;
when Iir_Kind_Simple_Name_Attribute =>
declare
use Str_Table;
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
Imp : constant Iir := Get_Implementation (Expr);
Left, Right : Iir;
begin
-- Note: there can't be association by name.
Left := Get_Parameter_Association_Chain (Expr);
Right := Get_Chain (Left);
Left := Eval_Static_Expr (Get_Actual (Left));
if Right = Null_Iir then
return Eval_Monadic_Operator (Expr, Left);
else
Right := Eval_Static_Expr (Get_Actual (Right));
return Eval_Dyadic_Operator (Expr, Imp, Left, Right);
end if;
end;
when Iir_Kind_Error =>
return Expr;
when others =>
Error_Kind ("eval_static_expr", Expr);
end case;
end Eval_Static_Expr;
-- If FORCE is true, always return a literal.
function Eval_Expr_Keep_Orig (Expr : Iir; Force : Boolean) return Iir
is
Res : Iir;
begin
case Get_Kind (Expr) is
when Iir_Kinds_Denoting_Name =>
declare
Orig : constant Iir := Get_Named_Entity (Expr);
begin
Res := Eval_Static_Expr (Orig);
if Res /= Orig or else Force then
return Build_Constant (Res, Expr);
else
return Expr;
end if;
end;
when others =>
Res := Eval_Static_Expr (Expr);
if Res /= Expr
and then Get_Literal_Origin (Res) /= Expr
then
-- Need to build a constant if the result is a different
-- literal not tied to EXPR.
return Build_Constant (Res, Expr);
else
return Res;
end if;
end case;
end Eval_Expr_Keep_Orig;
function Eval_Expr (Expr: Iir) return Iir is
begin
if Get_Expr_Staticness (Expr) /= Locally then
Error_Msg_Sem ("expression must be locally static", Expr);
return Expr;
else
return Eval_Expr_Keep_Orig (Expr, False);
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_Expr_Keep_Orig (Expr, False);
else
return Expr;
end if;
end Eval_Expr_If_Static;
function Eval_Expr_Check (Expr : Iir; Sub_Type : Iir) return Iir
is
Res : Iir;
begin
Res := Eval_Expr_Keep_Orig (Expr, False);
Eval_Check_Bound (Res, Sub_Type);
return Res;
end Eval_Expr_Check;
function Eval_Expr_Check_If_Static (Expr : Iir; Atype : Iir) return Iir
is
Res : Iir;
begin
if Expr /= Null_Iir and then Get_Expr_Staticness (Expr) = Locally then
-- Expression is static and can be evaluated.
Res := Eval_Expr_Keep_Orig (Expr, False);
if Res /= Null_Iir
and then Get_Type_Staticness (Atype) = Locally
and then Get_Kind (Atype) in Iir_Kinds_Range_Type_Definition
then
-- Check bounds (as this can be done).
-- FIXME: create overflow_expr ?
Eval_Check_Bound (Res, Atype);
end if;
return Res;
else
return Expr;
end if;
end Eval_Expr_Check_If_Static;
function Eval_Int_In_Range (Val : Iir_Int64; Bound : Iir) return Boolean is
begin
case Get_Kind (Bound) is
when Iir_Kind_Range_Expression =>
case Get_Direction (Bound) is
when Iir_To =>
if Val < Eval_Pos (Get_Left_Limit (Bound))
or else Val > Eval_Pos (Get_Right_Limit (Bound))
then
return False;
end if;
when Iir_Downto =>
if Val > Eval_Pos (Get_Left_Limit (Bound))
or else Val < Eval_Pos (Get_Right_Limit (Bound))
then
return False;
end if;
end case;
when others =>
Error_Kind ("eval_int_in_range", Bound);
end case;
return True;
end Eval_Int_In_Range;
function Eval_Phys_In_Range (Val : Iir_Int64; Bound : Iir) return Boolean
is
Left, Right : Iir_Int64;
begin
case Get_Kind (Bound) is
when Iir_Kind_Range_Expression =>
case Get_Kind (Get_Type (Get_Left_Limit (Bound))) is
when Iir_Kind_Integer_Type_Definition
| Iir_Kind_Integer_Subtype_Definition =>
Left := Get_Value (Get_Left_Limit (Bound));
Right := Get_Value (Get_Right_Limit (Bound));
when Iir_Kind_Physical_Type_Definition
| Iir_Kind_Physical_Subtype_Definition =>
Left := Get_Physical_Value (Get_Left_Limit (Bound));
Right := Get_Physical_Value (Get_Right_Limit (Bound));
when others =>
Error_Kind ("eval_phys_in_range(1)", Get_Type (Bound));
end case;
case Get_Direction (Bound) is
when Iir_To =>
if Val < Left or else Val > Right then
return False;
end if;
when Iir_Downto =>
if Val > Left or else Val < Right then
return False;
end if;
end case;
when others =>
Error_Kind ("eval_phys_in_range", Bound);
end case;
return True;
end Eval_Phys_In_Range;
function Eval_Fp_In_Range (Val : Iir_Fp64; Bound : Iir) return Boolean is
begin
case Get_Kind (Bound) is
when Iir_Kind_Range_Expression =>
case Get_Direction (Bound) is
when Iir_To =>
if Val < Get_Fp_Value (Get_Left_Limit (Bound))
or else Val > Get_Fp_Value (Get_Right_Limit (Bound))
then
return False;
end if;
when Iir_Downto =>
if Val > Get_Fp_Value (Get_Left_Limit (Bound))
or else Val < Get_Fp_Value (Get_Right_Limit (Bound))
then
return False;
end if;
end case;
when others =>
Error_Kind ("eval_fp_in_range", Bound);
end case;
return True;
end Eval_Fp_In_Range;
-- Return 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;
Val : Iir;
begin
case Get_Kind (Expr) is
when Iir_Kind_Error =>
-- Ignore errors.
return True;
when Iir_Kind_Overflow_Literal =>
-- Never within bounds
return False;
when Iir_Kind_Simple_Name
| Iir_Kind_Character_Literal
| Iir_Kind_Selected_Name =>
Val := Get_Named_Entity (Expr);
when others =>
Val := Expr;
end case;
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 (Val), Type_Range);
when Iir_Kind_Floating_Subtype_Definition =>
Type_Range := Get_Range_Constraint (Sub_Type);
return Eval_Fp_In_Range (Get_Fp_Value (Val), Type_Range);
when Iir_Kind_Enumeration_Subtype_Definition
| Iir_Kind_Enumeration_Type_Definition =>
-- A check is required for an enumeration type definition for
-- 'val attribute.
Type_Range := Get_Range_Constraint (Sub_Type);
return Eval_Int_In_Range
(Iir_Int64 (Get_Enum_Pos (Val)), Type_Range);
when Iir_Kind_Physical_Subtype_Definition =>
Type_Range := Get_Range_Constraint (Sub_Type);
return Eval_Phys_In_Range (Get_Physical_Value (Val), Type_Range);
when Iir_Kind_Base_Attribute =>
return Eval_Is_In_Bound (Val, 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 others =>
Error_Kind ("eval_is_in_bound", Sub_Type);
end case;
end Eval_Is_In_Bound;
procedure Eval_Check_Bound (Expr : Iir; Sub_Type : Iir) is
begin
if Get_Kind (Expr) = Iir_Kind_Overflow_Literal then
-- Nothing to check, and a message was already generated.
return;
end if;
if not Eval_Is_In_Bound (Expr, Sub_Type) then
Error_Msg_Sem ("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;
Range_Constraint : constant Iir := Eval_Static_Range (A_Range);
begin
Type_Range := Get_Range_Constraint (Sub_Type);
if not Any_Dir
and then Get_Direction (Type_Range) /= Get_Direction (Range_Constraint)
then
return True;
end if;
case Get_Kind (Sub_Type) is
when Iir_Kind_Integer_Subtype_Definition
| Iir_Kind_Physical_Subtype_Definition
| Iir_Kind_Enumeration_Subtype_Definition
| Iir_Kind_Enumeration_Type_Definition =>
declare
L, R : Iir_Int64;
begin
-- Check for null range.
L := Eval_Pos (Get_Left_Limit (Range_Constraint));
R := Eval_Pos (Get_Right_Limit (Range_Constraint));
case Get_Direction (Range_Constraint) is
when Iir_To =>
if L > R then
return True;
end if;
when Iir_Downto =>
if L < R then
return True;
end if;
end case;
return Eval_Int_In_Range (L, Type_Range)
and then Eval_Int_In_Range (R, Type_Range);
end;
when Iir_Kind_Floating_Subtype_Definition =>
declare
L, R : Iir_Fp64;
begin
-- Check for null range.
L := Get_Fp_Value (Get_Left_Limit (Range_Constraint));
R := Get_Fp_Value (Get_Right_Limit (Range_Constraint));
case Get_Direction (Range_Constraint) is
when Iir_To =>
if L > R then
return True;
end if;
when Iir_Downto =>
if L < R then
return True;
end if;
end case;
return Eval_Fp_In_Range (L, Type_Range)
and then Eval_Fp_In_Range (R, Type_Range);
end;
when others =>
Error_Kind ("eval_is_range_in_bound", Sub_Type);
end case;
-- Should check L <= R or L >= R according to direction.
--return Eval_Is_In_Bound (Get_Left_Limit (A_Range), Sub_Type)
-- and then Eval_Is_In_Bound (Get_Right_Limit (A_Range), Sub_Type);
end Eval_Is_Range_In_Bound;
procedure Eval_Check_Range
(A_Range : Iir; Sub_Type : Iir; Any_Dir : Boolean)
is
begin
if not Eval_Is_Range_In_Bound (A_Range, Sub_Type, Any_Dir) then
Error_Msg_Sem ("static range violates bounds", A_Range);
end if;
end Eval_Check_Range;
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
| Iir_Kind_Physical_Fp_Literal
| Iir_Kind_Unit_Declaration =>
return Get_Physical_Value (Expr);
when Iir_Kinds_Denoting_Name =>
return Eval_Pos (Get_Named_Entity (Expr));
when others =>
Error_Kind ("eval_pos", Expr);
end case;
end Eval_Pos;
function Eval_Static_Range (Rng : Iir) return Iir
is
Expr : Iir;
Kind : Iir_Kind;
begin
Expr := Rng;
loop
Kind := Get_Kind (Expr);
case Kind is
when Iir_Kind_Range_Expression =>
if Get_Expr_Staticness (Expr) /= Locally then
return Null_Iir;
end if;
-- Normalize the range expression.
Set_Left_Limit
(Expr, Eval_Expr_Keep_Orig (Get_Left_Limit (Expr), True));
Set_Right_Limit
(Expr, Eval_Expr_Keep_Orig (Get_Right_Limit (Expr), True));
return Expr;
when Iir_Kind_Integer_Subtype_Definition
| Iir_Kind_Floating_Subtype_Definition
| Iir_Kind_Enumeration_Type_Definition
| Iir_Kind_Enumeration_Subtype_Definition
| Iir_Kind_Physical_Subtype_Definition =>
Expr := Get_Range_Constraint (Expr);
when Iir_Kind_Range_Array_Attribute
| Iir_Kind_Reverse_Range_Array_Attribute =>
declare
Prefix : Iir;
Res : 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);
if Kind = Iir_Kind_Reverse_Range_Array_Attribute then
Expr := Eval_Static_Range (Expr);
Res := Create_Iir (Iir_Kind_Range_Expression);
Location_Copy (Res, Expr);
Set_Type (Res, Get_Type (Expr));
case Get_Direction (Expr) is
when Iir_To =>
Set_Direction (Res, Iir_Downto);
when Iir_Downto =>
Set_Direction (Res, Iir_To);
end case;
Set_Left_Limit (Res, Get_Right_Limit (Expr));
Set_Right_Limit (Res, Get_Left_Limit (Expr));
Set_Range_Origin (Res, Rng);
Set_Expr_Staticness (Res, Get_Expr_Staticness (Expr));
return Res;
end if;
end;
when Iir_Kind_Subtype_Declaration
| Iir_Kind_Base_Attribute =>
Expr := Get_Type (Expr);
when Iir_Kind_Type_Declaration =>
Expr := Get_Type_Definition (Expr);
when Iir_Kind_Simple_Name
| Iir_Kind_Selected_Name =>
Expr := Get_Named_Entity (Expr);
when others =>
Error_Kind ("eval_static_range", Expr);
end case;
end loop;
end Eval_Static_Range;
function Eval_Range (Arange : Iir) return Iir is
Res : Iir;
begin
Res := Eval_Static_Range (Arange);
if Res /= Arange
and then Get_Range_Origin (Res) /= Arange
then
return Build_Constant_Range (Res, Arange);
else
return Res;
end if;
end Eval_Range;
function Eval_Range_If_Static (Arange : Iir) return Iir is
begin
if Get_Expr_Staticness (Arange) /= Locally then
return Arange;
else
return Eval_Range (Arange);
end if;
end Eval_Range_If_Static;
-- Return the range constraint of a discrete range.
function Eval_Discrete_Range_Expression (Constraint : Iir) return Iir
is
Res : Iir;
begin
Res := Eval_Static_Range (Constraint);
if Res = Null_Iir then
Error_Kind ("eval_discrete_range_expression", Constraint);
else
return Res;
end if;
end Eval_Discrete_Range_Expression;
function Eval_Discrete_Range_Left (Constraint : Iir) return Iir
is
Range_Expr : Iir;
begin
Range_Expr := Eval_Discrete_Range_Expression (Constraint);
return Get_Left_Limit (Range_Expr);
end Eval_Discrete_Range_Left;
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));
if S = Null_Iir then
return -1;
end if;
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;
function Get_Path_Instance_Name_Suffix (Attr : Iir)
return Path_Instance_Name_Type
is
-- Current path for name attributes.
Path_Str : String_Acc := null;
Path_Maxlen : Natural := 0;
Path_Len : Natural;
Path_Instance : Iir;
procedure Deallocate is new Ada.Unchecked_Deallocation
(Name => String_Acc, Object => String);
procedure Path_Reset is
begin
Path_Len := 0;
Path_Instance := Null_Iir;
if Path_Maxlen = 0 then
Path_Maxlen := 256;
Path_Str := new String (1 .. Path_Maxlen);
end if;
end Path_Reset;
procedure Path_Add (Str : String)
is
N_Len : Natural;
N_Path : String_Acc;
begin
N_Len := Path_Maxlen;
loop
exit when Path_Len + Str'Length <= N_Len;
N_Len := N_Len * 2;
end loop;
if N_Len /= Path_Maxlen then
N_Path := new String (1 .. N_Len);
N_Path (1 .. Path_Len) := Path_Str (1 .. Path_Len);
Deallocate (Path_Str);
Path_Str := N_Path;
Path_Maxlen := N_Len;
end if;
Path_Str (Path_Len + 1 .. Path_Len + Str'Length) := Str;
Path_Len := Path_Len + Str'Length;
end Path_Add;
procedure Path_Add_Type_Name (Atype : Iir)
is
Adecl : Iir;
begin
Adecl := Get_Type_Declarator (Atype);
Image (Get_Identifier (Adecl));
Path_Add (Name_Buffer (1 .. Name_Length));
end Path_Add_Type_Name;
procedure Path_Add_Signature (Subprg : Iir)
is
Chain : Iir;
begin
Path_Add ("[");
Chain := Get_Interface_Declaration_Chain (Subprg);
while Chain /= Null_Iir loop
Path_Add_Type_Name (Get_Type (Chain));
Chain := Get_Chain (Chain);
if Chain /= Null_Iir then
Path_Add (",");
end if;
end loop;
case Get_Kind (Subprg) is
when Iir_Kind_Function_Declaration
| Iir_Kind_Implicit_Function_Declaration =>
Path_Add (" return ");
Path_Add_Type_Name (Get_Return_Type (Subprg));
when others =>
null;
end case;
Path_Add ("]");
end Path_Add_Signature;
procedure Path_Add_Name (N : Iir) is
begin
Eval_Simple_Name (Get_Identifier (N));
if Name_Buffer (1) /= 'P' then
-- Skip anonymous processes.
Path_Add (Name_Buffer (1 .. Name_Length));
end if;
end Path_Add_Name;
procedure Path_Add_Element (El : Iir; Is_Instance : Boolean) is
begin
-- LRM 14.1
-- E'INSTANCE_NAME
-- There is one full path instance element for each component
-- instantiation, block statement, generate statemenent, process
-- statement, or subprogram body in the design hierarchy between
-- the top design entity and the named entity denoted by the
-- prefix.
--
-- E'PATH_NAME
-- There is one path instance element for each component
-- instantiation, block statement, generate statement, process
-- statement, or subprogram body in the design hierarchy between
-- the root design entity and the named entity denoted by the
-- prefix.
case Get_Kind (El) is
when Iir_Kind_Library_Declaration =>
Path_Add (":");
Path_Add_Name (El);
Path_Add (":");
when Iir_Kind_Package_Declaration
| Iir_Kind_Package_Body =>
Path_Add_Element
(Get_Library (Get_Design_File (Get_Design_Unit (El))),
Is_Instance);
Path_Add_Name (El);
Path_Add (":");
when Iir_Kind_Entity_Declaration =>
Path_Instance := El;
when Iir_Kind_Architecture_Body =>
Path_Instance := El;
when Iir_Kind_Design_Unit =>
Path_Add_Element (Get_Library_Unit (El), Is_Instance);
when Iir_Kind_Sensitized_Process_Statement
| Iir_Kind_Process_Statement
| Iir_Kind_Block_Statement =>
Path_Add_Element (Get_Parent (El), Is_Instance);
Path_Add_Name (El);
Path_Add (":");
when Iir_Kind_Function_Declaration
| Iir_Kind_Procedure_Declaration
| Iir_Kind_Implicit_Function_Declaration
| Iir_Kind_Implicit_Procedure_Declaration =>
Path_Add_Element (Get_Parent (El), Is_Instance);
Path_Add_Name (El);
if Flags.Vhdl_Std >= Vhdl_02 then
-- Add signature.
Path_Add_Signature (El);
end if;
Path_Add (":");
when Iir_Kind_Procedure_Body =>
Path_Add_Element (Get_Subprogram_Specification (El),
Is_Instance);
when Iir_Kind_Generate_Statement =>
declare
Scheme : Iir;
begin
Scheme := Get_Generation_Scheme (El);
if Get_Kind (Scheme) = Iir_Kind_Iterator_Declaration then
Path_Instance := El;
else
Path_Add_Element (Get_Parent (El), Is_Instance);
Path_Add_Name (El);
Path_Add (":");
end if;
end;
when Iir_Kinds_Sequential_Statement =>
Path_Add_Element (Get_Parent (El), Is_Instance);
when others =>
Error_Kind ("path_add_element", El);
end case;
end Path_Add_Element;
Prefix : constant Iir := Get_Named_Entity (Get_Prefix (Attr));
Is_Instance : constant Boolean :=
Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute;
begin
Path_Reset;
-- LRM 14.1
-- E'PATH_NAME
-- The local item name in E'PATH_NAME equals E'SIMPLE_NAME, unless
-- E denotes a library, package, subprogram or label. In this
-- latter case, the package based path or instance based path,
-- as appropriate, will not contain a local item name.
--
-- E'INSTANCE_NAME
-- The local item name in E'INSTANCE_NAME equals E'SIMPLE_NAME,
-- unless E denotes a library, package, subprogram, or label. In
-- this latter case, the package based path or full instance based
-- path, as appropriate, will not contain a local item name.
case Get_Kind (Prefix) is
when Iir_Kind_Constant_Declaration
| Iir_Kind_Interface_Constant_Declaration
| Iir_Kind_Iterator_Declaration
| Iir_Kind_Variable_Declaration
| Iir_Kind_Interface_Variable_Declaration
| Iir_Kind_Signal_Declaration
| Iir_Kind_Interface_Signal_Declaration
| Iir_Kind_File_Declaration
| Iir_Kind_Interface_File_Declaration
| Iir_Kind_Type_Declaration
| Iir_Kind_Subtype_Declaration =>
Path_Add_Element (Get_Parent (Prefix), Is_Instance);
Path_Add_Name (Prefix);
when Iir_Kind_Library_Declaration
| Iir_Kinds_Library_Unit_Declaration
| Iir_Kind_Function_Declaration
| Iir_Kind_Procedure_Declaration
| Iir_Kind_Implicit_Function_Declaration
| Iir_Kind_Implicit_Procedure_Declaration
| Iir_Kinds_Concurrent_Statement
| Iir_Kinds_Sequential_Statement =>
Path_Add_Element (Prefix, Is_Instance);
when others =>
Error_Kind ("get_path_instance_name_suffix", Prefix);
end case;
declare
Result : constant Path_Instance_Name_Type :=
(Len => Path_Len,
Path_Instance => Path_Instance,
Suffix => Path_Str (1 .. Path_Len));
begin
Deallocate (Path_Str);
return Result;
end;
end Get_Path_Instance_Name_Suffix;
end Evaluation;