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