diff options
| author | Tristan Gingold <tgingold@free.fr> | 2017-11-24 06:21:01 +0100 |
|---|---|---|
| committer | Tristan Gingold <tgingold@free.fr> | 2017-11-24 06:21:01 +0100 |
| commit | 49294a83ee67eef83180721c578f69855bf96cad (patch) | |
| tree | 89d3eab1be8bcc27a64340a6d69ad71a2b51adea /src/vhdl/simulate/execution.adb | |
| parent | 947d5b8876198dda1cf8e0c65a554e5dbd5e80f2 (diff) | |
| download | ghdl-49294a83ee67eef83180721c578f69855bf96cad.tar.gz ghdl-49294a83ee67eef83180721c578f69855bf96cad.tar.bz2 ghdl-49294a83ee67eef83180721c578f69855bf96cad.zip | |
Create the simul.ads package (for a namespace).
Diffstat (limited to 'src/vhdl/simulate/execution.adb')
| -rw-r--r-- | src/vhdl/simulate/execution.adb | 4831 |
1 files changed, 0 insertions, 4831 deletions
diff --git a/src/vhdl/simulate/execution.adb b/src/vhdl/simulate/execution.adb deleted file mode 100644 index dc4792490..000000000 --- a/src/vhdl/simulate/execution.adb +++ /dev/null @@ -1,4831 +0,0 @@ --- Interpreted simulation --- Copyright (C) 2014 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_Conversion; -with Ada.Text_IO; use Ada.Text_IO; -with System; -with Grt.Types; use Grt.Types; -with Flags; use Flags; -with Errorout; use Errorout; -with Std_Package; -with Evaluation; -with Iirs_Utils; use Iirs_Utils; -with Annotations; use Annotations; -with Name_Table; -with File_Operation; -with Debugger; use Debugger; -with Std_Names; -with Str_Table; -with Files_Map; -with Iir_Chains; use Iir_Chains; -with Simulation; use Simulation; -with Grt.Astdio; -with Grt.Stdio; -with Grt.Options; -with Grt.Vstrings; -with Grt_Interface; -with Grt.Values; -with Grt.Errors; -with Grt.Std_Logic_1164; -with Grt.Lib; -with Grt.Strings; -with Sem_Inst; - -package body Execution is - - function Execute_Function_Call - (Block: Block_Instance_Acc; Expr: Iir; Imp : Iir) - return Iir_Value_Literal_Acc; - - procedure Finish_Sequential_Statements - (Proc : Process_State_Acc; Complex_Stmt : Iir); - procedure Init_Sequential_Statements - (Proc : Process_State_Acc; Complex_Stmt : Iir); - procedure Update_Next_Statement (Proc : Process_State_Acc); - - -- Display a message when an assertion has failed. - procedure Execute_Failed_Assertion (Msg : String; - Report : String; - Severity : Natural; - Stmt: Iir); - - function Get_Instance_By_Scope - (Instance: Block_Instance_Acc; Scope: Scope_Type) - return Block_Instance_Acc is - begin - case Scope.Kind is - when Scope_Kind_Frame => - declare - Current : Block_Instance_Acc; - Last : Block_Instance_Acc; - begin - Current := Instance; - while Current /= null loop - if Current.Block_Scope = Scope then - return Current; - end if; - Last := Current; - Current := Current.Up_Block; - end loop; - if Scope.Depth = 0 - and then Last.Block_Scope.Kind = Scope_Kind_Package - then - -- For instantiated packages. - return Last; - end if; - raise Internal_Error; - end; - when Scope_Kind_Package => - -- Global scope (packages) - return Package_Instances (Scope.Pkg_Index); - when Scope_Kind_Component => - pragma Assert (Current_Component /= null); - return Current_Component; - when Scope_Kind_None => - raise Internal_Error; - when Scope_Kind_Pkg_Inst => - raise Internal_Error; - end case; - end Get_Instance_By_Scope; - - function Get_Instance_For_Slot (Instance: Block_Instance_Acc; Decl: Iir) - return Block_Instance_Acc is - begin - return Get_Instance_By_Scope (Instance, Get_Info (Decl).Obj_Scope); - end Get_Instance_For_Slot; - - procedure Create_Right_Bound_From_Length - (Bounds : Iir_Value_Literal_Acc; Len : Iir_Index32) - is - begin - pragma Assert (Bounds.Right = null); - - case Bounds.Left.Kind is - when Iir_Value_E32 => - declare - R : Ghdl_E32; - begin - case Bounds.Dir is - when Iir_To => - R := Bounds.Left.E32 + Ghdl_E32 (Len - 1); - when Iir_Downto => - R := Bounds.Left.E32 - Ghdl_E32 (Len - 1); - end case; - Bounds.Right := Create_E32_Value (R); - end; - when Iir_Value_I64 => - declare - R : Ghdl_I64; - begin - case Bounds.Dir is - when Iir_To => - R := Bounds.Left.I64 + Ghdl_I64 (Len - 1); - when Iir_Downto => - R := Bounds.Left.I64 - Ghdl_I64 (Len - 1); - end case; - Bounds.Right := Create_I64_Value (R); - end; - when others => - raise Internal_Error; - end case; - end Create_Right_Bound_From_Length; - - function Create_Bounds_From_Length (Block : Block_Instance_Acc; - Atype : Iir; - Len : Iir_Index32) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - Index_Bounds : Iir_Value_Literal_Acc; - begin - Index_Bounds := Execute_Bounds (Block, Atype); - - Res := Create_Range_Value (Left => Index_Bounds.Left, - Right => null, - Dir => Index_Bounds.Dir, - Length => Len); - - if Len = 0 then - -- Special case. - Res.Right := Res.Left; - case Res.Left.Kind is - when Iir_Value_I64 => - case Index_Bounds.Dir is - when Iir_To => - Res.Left := Create_I64_Value (Res.Right.I64 + 1); - when Iir_Downto => - Res.Left := Create_I64_Value (Res.Right.I64 - 1); - end case; - when others => - raise Internal_Error; - end case; - else - Create_Right_Bound_From_Length (Res, Len); - end if; - return Res; - end Create_Bounds_From_Length; - - function Execute_High_Limit (Bounds : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - if Bounds.Dir = Iir_To then - return Bounds.Right; - else - return Bounds.Left; - end if; - end Execute_High_Limit; - - function Execute_Low_Limit (Bounds : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - if Bounds.Dir = Iir_To then - return Bounds.Left; - else - return Bounds.Right; - end if; - end Execute_Low_Limit; - - function Execute_Left_Limit (Bounds : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - return Bounds.Left; - end Execute_Left_Limit; - - function Execute_Right_Limit (Bounds : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - return Bounds.Right; - end Execute_Right_Limit; - - function Execute_Length (Bounds : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc is - begin - return Create_I64_Value (Ghdl_I64 (Bounds.Length)); - end Execute_Length; - - function Create_Enum_Value (Pos : Natural; Etype : Iir) - return Iir_Value_Literal_Acc - is - Base_Type : constant Iir := Get_Base_Type (Etype); - Mode : constant Iir_Value_Kind := - Get_Info (Base_Type).Scalar_Mode; - begin - case Iir_Value_Enums (Mode) is - when Iir_Value_E8 => - return Create_E8_Value (Ghdl_E8 (Pos)); - when Iir_Value_E32 => - return Create_E32_Value (Ghdl_E32 (Pos)); - when Iir_Value_B1 => - return Create_B1_Value (Ghdl_B1'Val (Pos)); - end case; - end Create_Enum_Value; - - function String_To_Iir_Value (Str : String) return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - Res := Create_Array_Value (Str'Length, 1); - Res.Bounds.D (1) := Create_Range_Value - (Create_I64_Value (1), - Create_I64_Value (Str'Length), - Iir_To); - for I in Str'Range loop - Res.Val_Array.V (1 + Iir_Index32 (I - Str'First)) := - Create_E8_Value (Character'Pos (Str (I))); - end loop; - return Res; - end String_To_Iir_Value; - - function Execute_Image_Attribute (Val : Iir_Value_Literal_Acc; - Expr_Type : Iir) - return String - is - begin - case Get_Kind (Expr_Type) is - when Iir_Kind_Floating_Type_Definition - | Iir_Kind_Floating_Subtype_Definition => - declare - Str : String (1 .. 24); - Last : Natural; - begin - Grt.Vstrings.To_String (Str, Last, Val.F64); - return Str (Str'First .. Last); - end; - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Integer_Subtype_Definition => - declare - Str : String (1 .. 21); - First : Natural; - begin - Grt.Vstrings.To_String (Str, First, Val.I64); - return Str (First .. Str'Last); - end; - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - declare - Lits : constant Iir_Flist := - Get_Enumeration_Literal_List (Get_Base_Type (Expr_Type)); - Pos : Natural; - begin - case Iir_Value_Enums (Val.Kind) is - when Iir_Value_B1 => - Pos := Ghdl_B1'Pos (Val.B1); - when Iir_Value_E8 => - Pos := Ghdl_E8'Pos (Val.E8); - when Iir_Value_E32 => - Pos := Ghdl_E32'Pos (Val.E32); - end case; - return Name_Table.Image - (Get_Identifier (Get_Nth_Element (Lits, Pos))); - end; - when Iir_Kind_Physical_Type_Definition - | Iir_Kind_Physical_Subtype_Definition => - declare - Str : String (1 .. 21); - First : Natural; - Id : constant Name_Id := - Get_Identifier (Get_Primary_Unit (Get_Base_Type (Expr_Type))); - begin - Grt.Vstrings.To_String (Str, First, Val.I64); - return Str (First .. Str'Last) & ' ' & Name_Table.Image (Id); - end; - when others => - Error_Kind ("execute_image_attribute", Expr_Type); - end case; - end Execute_Image_Attribute; - - function Execute_Image_Attribute (Block: Block_Instance_Acc; Expr: Iir) - return Iir_Value_Literal_Acc - is - Val : Iir_Value_Literal_Acc; - Attr_Type : constant Iir := Get_Type (Get_Prefix (Expr)); - begin - Val := Execute_Expression (Block, Get_Parameter (Expr)); - return String_To_Iir_Value - (Execute_Image_Attribute (Val, Attr_Type)); - end Execute_Image_Attribute; - - function Execute_Path_Instance_Name_Attribute - (Block : Block_Instance_Acc; Attr : Iir) return Iir_Value_Literal_Acc - is - use Evaluation; - use Grt.Vstrings; - use Name_Table; - - Name : constant Path_Instance_Name_Type := - Get_Path_Instance_Name_Suffix (Attr); - Instance : Block_Instance_Acc; - Rstr : Rstring; - Is_Instance : constant Boolean := - Get_Kind (Attr) = Iir_Kind_Instance_Name_Attribute; - begin - if Name.Path_Instance = Null_Iir then - return String_To_Iir_Value (Name.Suffix); - end if; - - Instance := Get_Instance_By_Scope - (Block, Get_Info (Name.Path_Instance).Frame_Scope); - - loop - case Get_Kind (Instance.Label) is - when Iir_Kind_Entity_Declaration => - if Instance.Parent = null then - Prepend (Rstr, Image (Get_Identifier (Instance.Label))); - exit; - end if; - when Iir_Kind_Architecture_Body => - if Is_Instance then - Prepend (Rstr, ')'); - Prepend (Rstr, Image (Get_Identifier (Instance.Label))); - Prepend (Rstr, '('); - end if; - - if Is_Instance or else Instance.Parent = null then - Prepend - (Rstr, - Image (Get_Identifier (Get_Entity (Instance.Label)))); - end if; - if Instance.Parent = null then - Prepend (Rstr, ':'); - exit; - else - Instance := Instance.Parent; - end if; - when Iir_Kind_Block_Statement => - Prepend (Rstr, Image (Get_Label (Instance.Label))); - Prepend (Rstr, ':'); - Instance := Instance.Parent; - when Iir_Kind_Iterator_Declaration => - declare - Val : Iir_Value_Literal_Acc; - begin - Val := Execute_Name (Instance, Instance.Label); - Prepend (Rstr, ')'); - Prepend (Rstr, Execute_Image_Attribute - (Val, Get_Type (Instance.Label))); - Prepend (Rstr, '('); - end; - Instance := Instance.Parent; - when Iir_Kind_Generate_Statement_Body => - Prepend (Rstr, Image (Get_Label (Get_Parent (Instance.Label)))); - Prepend (Rstr, ':'); - Instance := Instance.Parent; - when Iir_Kind_Component_Instantiation_Statement => - if Is_Instance then - Prepend (Rstr, '@'); - end if; - Prepend (Rstr, Image (Get_Label (Instance.Label))); - Prepend (Rstr, ':'); - Instance := Instance.Parent; - when others => - Error_Kind ("Execute_Path_Instance_Name_Attribute", - Instance.Label); - end case; - end loop; - declare - Str1 : String (1 .. Length (Rstr)); - Len1 : Natural; - begin - Copy (Rstr, Str1, Len1); - Free (Rstr); - return String_To_Iir_Value (Str1 & ':' & Name.Suffix); - end; - end Execute_Path_Instance_Name_Attribute; - - function Execute_Shift_Operator (Left : Iir_Value_Literal_Acc; - Count : Ghdl_I64; - Expr : Iir) - return Iir_Value_Literal_Acc - is - Func : constant Iir_Predefined_Shift_Functions := - Get_Implicit_Definition (Get_Implementation (Expr)); - Cnt : Iir_Index32; - Len : constant Iir_Index32 := Left.Bounds.D (1).Length; - Dir_Left : Boolean; - P : Iir_Index32; - Res : Iir_Value_Literal_Acc; - E : Iir_Value_Literal_Acc; - 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 else Len = 0 then - return 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 := Iir_Index32 (-Count); - Dir_Left := not Dir_Left; - else - Cnt := Iir_Index32 (Count); - end if; - - case Func is - when Iir_Predefined_Array_Sll - | Iir_Predefined_Array_Srl => - E := Create_Enum_Value - (0, Get_Element_Subtype (Get_Base_Type (Get_Type (Expr)))); - when Iir_Predefined_Array_Sla - | Iir_Predefined_Array_Sra => - if Dir_Left then - E := Left.Val_Array.V (Len); - else - E := Left.Val_Array.V (1); - 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 := Create_Array_Value (1); - Res.Bounds.D (1) := Left.Bounds.D (1); - Create_Array_Data (Res, Len); - P := 1; - - 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 - Res.Val_Array.V (P) := Left.Val_Array.V (I + 1); - P := P + 1; - end loop; - else - Cnt := Len; - end if; - for I in 0 .. Cnt - 1 loop - Res.Val_Array.V (P) := E; - P := P + 1; - end loop; - else - if Cnt > Len then - Cnt := Len; - end if; - for I in 0 .. Cnt - 1 loop - Res.Val_Array.V (P) := E; - P := P + 1; - end loop; - for I in Cnt .. Len - 1 loop - Res.Val_Array.V (P) := Left.Val_Array.V (I - Cnt + 1); - P := P + 1; - end loop; - end if; - when Iir_Predefined_Array_Rol - | Iir_Predefined_Array_Ror => - for I in 1 .. Len loop - Res.Val_Array.V (P) := Left.Val_Array.V (Cnt + 1); - P := P + 1; - Cnt := Cnt + 1; - if Cnt = Len then - Cnt := 0; - end if; - end loop; - end case; - return Res; - end Execute_Shift_Operator; - - Hex_Chars : constant array (Natural range 0 .. 15) of Character := - "0123456789ABCDEF"; - - function Execute_Bit_Vector_To_String (Val : Iir_Value_Literal_Acc; - Log_Base : Natural) - return Iir_Value_Literal_Acc - is - Base : constant Natural := 2 ** Log_Base; - Blen : constant Natural := Natural (Val.Bounds.D (1).Length); - Str : String (1 .. (Blen + Log_Base - 1) / Log_Base); - Pos : Natural; - V : Natural; - N : Natural; - begin - V := 0; - N := 1; - Pos := Str'Last; - for I in reverse Val.Val_Array.V'Range loop - V := V + Ghdl_B1'Pos (Val.Val_Array.V (I).B1) * N; - N := N * 2; - if N = Base or else I = Val.Val_Array.V'First then - Str (Pos) := Hex_Chars (V); - Pos := Pos - 1; - N := 1; - V := 0; - end if; - end loop; - return String_To_Iir_Value (Str); - end Execute_Bit_Vector_To_String; - - procedure Assert_Std_Ulogic_Dc (Loc : Iir) - is - use Grt.Std_Logic_1164; - begin - Execute_Failed_Assertion - ("assertion", - "STD_LOGIC_1164: '-' operand for matching ordering operator", - 1, Loc); - end Assert_Std_Ulogic_Dc; - - procedure Check_Std_Ulogic_Dc (Loc : Iir; V : Grt.Std_Logic_1164.Std_Ulogic) - is - use Grt.Std_Logic_1164; - begin - if V = '-' then - Assert_Std_Ulogic_Dc (Loc); - end if; - end Check_Std_Ulogic_Dc; - - -- EXPR is the expression whose implementation is an implicit function. - function Execute_Implicit_Function (Block : Block_Instance_Acc; - Expr: Iir; - Left_Param : Iir; - Right_Param : Iir; - Res_Type : Iir) - return Iir_Value_Literal_Acc - is - pragma Unsuppress (Overflow_Check); - - Imp : constant Iir := Strip_Denoting_Name (Get_Implementation (Expr)); - Func : constant Iir_Predefined_Functions := - Get_Implicit_Definition (Imp); - - -- Rename definition for monadic operations. - Left, Right: Iir_Value_Literal_Acc; - Operand : Iir_Value_Literal_Acc renames Left; - Result: Iir_Value_Literal_Acc; - - procedure Eval_Right is - begin - Right := Execute_Expression (Block, Right_Param); - end Eval_Right; - - -- Eval right argument, check left and right have same length, - -- Create RESULT from left. - procedure Eval_Array is - begin - Eval_Right; - if Left.Bounds.D (1).Length /= Right.Bounds.D (1).Length then - Error_Msg_Constraint (Expr); - end if; - -- Need to copy as the result is modified. - Result := Unshare (Left, Expr_Pool'Access); - end Eval_Array; - begin - -- Eval left operand. - case Func is - when Iir_Predefined_Now_Function => - Left := null; - when Iir_Predefined_Bit_Rising_Edge - | Iir_Predefined_Boolean_Rising_Edge - | Iir_Predefined_Bit_Falling_Edge - | Iir_Predefined_Boolean_Falling_Edge=> - Operand := Execute_Name (Block, Left_Param, True); - when others => - Left := Execute_Expression (Block, Left_Param); - end case; - Right := null; - - case Func is - when Iir_Predefined_Error => - raise Internal_Error; - - when Iir_Predefined_Array_Array_Concat - | Iir_Predefined_Element_Array_Concat - | Iir_Predefined_Array_Element_Concat - | Iir_Predefined_Element_Element_Concat => - Eval_Right; - - declare - -- Array length of the result. - Len: Iir_Index32; - - -- Index into the result. - Pos: Iir_Index32; - begin - -- Compute the length of the result. - case Func is - when Iir_Predefined_Array_Array_Concat => - Len := Left.Val_Array.Len + Right.Val_Array.Len; - when Iir_Predefined_Element_Array_Concat => - Len := 1 + Right.Val_Array.Len; - when Iir_Predefined_Array_Element_Concat => - Len := Left.Val_Array.Len + 1; - when Iir_Predefined_Element_Element_Concat => - Len := 1 + 1; - when others => - raise Program_Error; - end case; - - if Func = Iir_Predefined_Array_Array_Concat - and then Left.Val_Array.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. - return Right; - else - -- LRM93 7.2.4 - -- If both operands are null arrays, then the result of - -- the concatenation is the right operand. - if Right.Val_Array.Len = 0 then - return Right; - end if; - end if; - end if; - - 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 Adding Operators - -- The left bound if this result is the left bound of the - -- left operand, [...]. The direction of the result is the - -- direction of the left operand, unless the left operand - -- is a null array, in which case the direction of the - -- result is that of the right operand. - Result := Create_Array_Value (Len, 1); - Result.Bounds.D (1) := Create_Range_Value - (Left.Bounds.D (1).Left, null, Left.Bounds.D (1).Dir, Len); - Create_Right_Bound_From_Length (Result.Bounds.D (1), Len); - else - -- Create the array result. - Result := Create_Array_Value (Len, 1); - Result.Bounds.D (1) := Create_Bounds_From_Length - (Block, - Get_Nth_Element (Get_Index_Subtype_List (Res_Type), 0), - Len); - end if; - - -- Fill the result: left. - case Func is - when Iir_Predefined_Array_Array_Concat - | Iir_Predefined_Array_Element_Concat => - for I in Left.Val_Array.V'Range loop - Result.Val_Array.V (I) := Left.Val_Array.V (I); - end loop; - Pos := Left.Val_Array.Len; - when Iir_Predefined_Element_Array_Concat - | Iir_Predefined_Element_Element_Concat => - Result.Val_Array.V (1) := Left; - Pos := 1; - when others => - raise Program_Error; - end case; - - -- Note: here POS is equal to the position of the last element - -- filled, or 0 if no elements were filled. - - -- Fill the result: right. - case Func is - when Iir_Predefined_Array_Array_Concat - | Iir_Predefined_Element_Array_Concat => - for I in Right.Val_Array.V'Range loop - Result.Val_Array.V (Pos + I) := Right.Val_Array.V (I); - end loop; - when Iir_Predefined_Array_Element_Concat - | Iir_Predefined_Element_Element_Concat => - Result.Val_Array.V (Pos + 1) := Right; - when others => - raise Program_Error; - end case; - end; - - when Iir_Predefined_Bit_And - | Iir_Predefined_Boolean_And => - if Left.B1 = Lit_Enum_0.B1 then - -- Short circuit operator. - Result := Lit_Enum_0; - else - Eval_Right; - Result := Boolean_To_Lit (Right.B1 = Lit_Enum_1.B1); - end if; - when Iir_Predefined_Bit_Nand - | Iir_Predefined_Boolean_Nand => - if Left.B1 = Lit_Enum_0.B1 then - -- Short circuit operator. - Result := Lit_Enum_1; - else - Eval_Right; - Result := Boolean_To_Lit (Right.B1 = Lit_Enum_0.B1); - end if; - when Iir_Predefined_Bit_Or - | Iir_Predefined_Boolean_Or => - if Left.B1 = Lit_Enum_1.B1 then - -- Short circuit operator. - Result := Lit_Enum_1; - else - Eval_Right; - Result := Boolean_To_Lit (Right.B1 = Lit_Enum_1.B1); - end if; - when Iir_Predefined_Bit_Nor - | Iir_Predefined_Boolean_Nor => - if Left.B1 = Lit_Enum_1.B1 then - -- Short circuit operator. - Result := Lit_Enum_0; - else - Eval_Right; - Result := Boolean_To_Lit (Right.B1 = Lit_Enum_0.B1); - end if; - when Iir_Predefined_Bit_Xor - | Iir_Predefined_Boolean_Xor => - Eval_Right; - Result := Boolean_To_Lit (Left.B1 /= Right.B1); - when Iir_Predefined_Bit_Xnor - | Iir_Predefined_Boolean_Xnor => - Eval_Right; - Result := Boolean_To_Lit (Left.B1 = Right.B1); - when Iir_Predefined_Bit_Not - | Iir_Predefined_Boolean_Not => - Result := Boolean_To_Lit (Operand.B1 = Lit_Enum_0.B1); - - when Iir_Predefined_Bit_Condition => - Result := Boolean_To_Lit (Operand.B1 = Lit_Enum_1.B1); - - 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 => - Eval_Right; - Result := Execute_Shift_Operator (Left, Right.I64, Expr); - - when Iir_Predefined_Enum_Equality - | Iir_Predefined_Integer_Equality - | Iir_Predefined_Array_Equality - | Iir_Predefined_Access_Equality - | Iir_Predefined_Physical_Equality - | Iir_Predefined_Floating_Equality - | Iir_Predefined_Record_Equality - | Iir_Predefined_Bit_Match_Equality - | Iir_Predefined_Bit_Array_Match_Equality => - Eval_Right; - Result := Boolean_To_Lit (Is_Equal (Left, Right)); - when Iir_Predefined_Enum_Inequality - | Iir_Predefined_Integer_Inequality - | Iir_Predefined_Array_Inequality - | Iir_Predefined_Access_Inequality - | Iir_Predefined_Physical_Inequality - | Iir_Predefined_Floating_Inequality - | Iir_Predefined_Record_Inequality - | Iir_Predefined_Bit_Match_Inequality - | Iir_Predefined_Bit_Array_Match_Inequality => - Eval_Right; - Result := Boolean_To_Lit (not Is_Equal (Left, Right)); - when Iir_Predefined_Integer_Less - | Iir_Predefined_Physical_Less - | Iir_Predefined_Enum_Less => - Eval_Right; - Result := Boolean_To_Lit (Compare_Value (Left, Right) < Equal); - when Iir_Predefined_Integer_Greater - | Iir_Predefined_Physical_Greater - | Iir_Predefined_Enum_Greater => - Eval_Right; - Result := Boolean_To_Lit (Compare_Value (Left, Right) > Equal); - when Iir_Predefined_Integer_Less_Equal - | Iir_Predefined_Physical_Less_Equal - | Iir_Predefined_Enum_Less_Equal => - Eval_Right; - Result := Boolean_To_Lit (Compare_Value (Left, Right) <= Equal); - when Iir_Predefined_Integer_Greater_Equal - | Iir_Predefined_Physical_Greater_Equal - | Iir_Predefined_Enum_Greater_Equal => - Eval_Right; - Result := Boolean_To_Lit (Compare_Value (Left, Right) >= Equal); - - when Iir_Predefined_Enum_Minimum - | Iir_Predefined_Physical_Minimum => - Eval_Right; - if Compare_Value (Left, Right) = Less then - Result := Left; - else - Result := Right; - end if; - when Iir_Predefined_Enum_Maximum - | Iir_Predefined_Physical_Maximum => - Eval_Right; - if Compare_Value (Left, Right) = Less then - Result := Right; - else - Result := Left; - end if; - - when Iir_Predefined_Integer_Plus - | Iir_Predefined_Physical_Plus => - Eval_Right; - case Left.Kind is - when Iir_Value_I64 => - Result := Create_I64_Value (Left.I64 + Right.I64); - when others => - raise Internal_Error; - end case; - when Iir_Predefined_Integer_Minus - | Iir_Predefined_Physical_Minus => - Eval_Right; - case Left.Kind is - when Iir_Value_I64 => - Result := Create_I64_Value (Left.I64 - Right.I64); - when others => - raise Internal_Error; - end case; - when Iir_Predefined_Integer_Mul => - Eval_Right; - case Left.Kind is - when Iir_Value_I64 => - Result := Create_I64_Value (Left.I64 * Right.I64); - when others => - raise Internal_Error; - end case; - when Iir_Predefined_Integer_Mod => - Eval_Right; - case Left.Kind is - when Iir_Value_I64 => - if Right.I64 = 0 then - Error_Msg_Constraint (Expr); - end if; - Result := Create_I64_Value (Left.I64 mod Right.I64); - when others => - raise Internal_Error; - end case; - when Iir_Predefined_Integer_Rem => - Eval_Right; - case Left.Kind is - when Iir_Value_I64 => - if Right.I64 = 0 then - Error_Msg_Constraint (Expr); - end if; - Result := Create_I64_Value (Left.I64 rem Right.I64); - when others => - raise Internal_Error; - end case; - when Iir_Predefined_Integer_Div => - Eval_Right; - case Left.Kind is - when Iir_Value_I64 => - if Right.I64 = 0 then - Error_Msg_Constraint (Expr); - end if; - Result := Create_I64_Value (Left.I64 / Right.I64); - when others => - raise Internal_Error; - end case; - - when Iir_Predefined_Integer_Absolute - | Iir_Predefined_Physical_Absolute => - case Operand.Kind is - when Iir_Value_I64 => - Result := Create_I64_Value (abs Operand.I64); - when others => - raise Internal_Error; - end case; - - when Iir_Predefined_Integer_Negation - | Iir_Predefined_Physical_Negation => - case Operand.Kind is - when Iir_Value_I64 => - Result := Create_I64_Value (-Operand.I64); - when others => - raise Internal_Error; - end case; - - when Iir_Predefined_Integer_Identity - | Iir_Predefined_Physical_Identity => - case Operand.Kind is - when Iir_Value_I64 => - Result := Create_I64_Value (Operand.I64); - when others => - raise Internal_Error; - end case; - - when Iir_Predefined_Integer_Exp => - Eval_Right; - case Left.Kind is - when Iir_Value_I64 => - if Right.I64 < 0 then - Error_Msg_Constraint (Expr); - end if; - Result := Create_I64_Value (Left.I64 ** Natural (Right.I64)); - when others => - raise Internal_Error; - end case; - - when Iir_Predefined_Integer_Minimum => - Eval_Right; - Result := Create_I64_Value (Ghdl_I64'Min (Left.I64, Right.I64)); - when Iir_Predefined_Integer_Maximum => - Eval_Right; - Result := Create_I64_Value (Ghdl_I64'Max (Left.I64, Right.I64)); - - when Iir_Predefined_Floating_Mul => - Eval_Right; - Result := Create_F64_Value (Left.F64 * Right.F64); - when Iir_Predefined_Floating_Div => - Eval_Right; - Result := Create_F64_Value (Left.F64 / Right.F64); - when Iir_Predefined_Floating_Minus => - Eval_Right; - Result := Create_F64_Value (Left.F64 - Right.F64); - when Iir_Predefined_Floating_Plus => - Eval_Right; - Result := Create_F64_Value (Left.F64 + Right.F64); - when Iir_Predefined_Floating_Exp => - Eval_Right; - Result := Create_F64_Value (Left.F64 ** Integer (Right.I64)); - when Iir_Predefined_Floating_Identity => - Result := Create_F64_Value (Operand.F64); - when Iir_Predefined_Floating_Negation => - Result := Create_F64_Value (-Operand.F64); - when Iir_Predefined_Floating_Absolute => - Result := Create_F64_Value (abs (Operand.F64)); - when Iir_Predefined_Floating_Less => - Eval_Right; - Result := Boolean_To_Lit (Left.F64 < Right.F64); - when Iir_Predefined_Floating_Less_Equal => - Eval_Right; - Result := Boolean_To_Lit (Left.F64 <= Right.F64); - when Iir_Predefined_Floating_Greater => - Eval_Right; - Result := Boolean_To_Lit (Left.F64 > Right.F64); - when Iir_Predefined_Floating_Greater_Equal => - Eval_Right; - Result := Boolean_To_Lit (Left.F64 >= Right.F64); - - when Iir_Predefined_Floating_Minimum => - Eval_Right; - Result := Create_F64_Value (Ghdl_F64'Min (Left.F64, Right.F64)); - when Iir_Predefined_Floating_Maximum => - Eval_Right; - Result := Create_F64_Value (Ghdl_F64'Max (Left.F64, Right.F64)); - - when Iir_Predefined_Integer_Physical_Mul => - Eval_Right; - Result := Create_I64_Value (Left.I64 * Right.I64); - when Iir_Predefined_Physical_Integer_Mul => - Eval_Right; - Result := Create_I64_Value (Left.I64 * Right.I64); - when Iir_Predefined_Physical_Physical_Div => - Eval_Right; - Result := Create_I64_Value (Left.I64 / Right.I64); - when Iir_Predefined_Physical_Integer_Div => - Eval_Right; - Result := Create_I64_Value (Left.I64 / Right.I64); - when Iir_Predefined_Real_Physical_Mul => - Eval_Right; - Result := Create_I64_Value - (Ghdl_I64 (Left.F64 * Ghdl_F64 (Right.I64))); - when Iir_Predefined_Physical_Real_Mul => - Eval_Right; - Result := Create_I64_Value - (Ghdl_I64 (Ghdl_F64 (Left.I64) * Right.F64)); - when Iir_Predefined_Physical_Real_Div => - Eval_Right; - Result := Create_I64_Value - (Ghdl_I64 (Ghdl_F64 (Left.I64) / Right.F64)); - - when Iir_Predefined_Universal_I_R_Mul => - Eval_Right; - Result := Create_F64_Value (Ghdl_F64 (Left.I64) * Right.F64); - when Iir_Predefined_Universal_R_I_Mul => - Eval_Right; - Result := Create_F64_Value (Left.F64 * Ghdl_F64 (Right.I64)); - - when Iir_Predefined_TF_Array_And => - Eval_Array; - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 and Right.Val_Array.V (I).B1; - end loop; - when Iir_Predefined_TF_Array_Nand => - Eval_Array; - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 and Right.Val_Array.V (I).B1); - end loop; - when Iir_Predefined_TF_Array_Or => - Eval_Array; - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 or Right.Val_Array.V (I).B1; - end loop; - when Iir_Predefined_TF_Array_Nor => - Eval_Array; - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 or Right.Val_Array.V (I).B1); - end loop; - when Iir_Predefined_TF_Array_Xor => - Eval_Array; - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 xor Right.Val_Array.V (I).B1; - end loop; - when Iir_Predefined_TF_Array_Xnor => - Eval_Array; - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 xor Right.Val_Array.V (I).B1); - end loop; - - when Iir_Predefined_TF_Array_Element_And => - Eval_Right; - Result := Unshare (Left, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 and Right.B1; - end loop; - when Iir_Predefined_TF_Element_Array_And => - Eval_Right; - Result := Unshare (Right, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 and Left.B1; - end loop; - - when Iir_Predefined_TF_Array_Element_Or => - Eval_Right; - Result := Unshare (Left, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 or Right.B1; - end loop; - when Iir_Predefined_TF_Element_Array_Or => - Eval_Right; - Result := Unshare (Right, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 or Left.B1; - end loop; - - when Iir_Predefined_TF_Array_Element_Xor => - Eval_Right; - Result := Unshare (Left, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 xor Right.B1; - end loop; - when Iir_Predefined_TF_Element_Array_Xor => - Eval_Right; - Result := Unshare (Right, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - Result.Val_Array.V (I).B1 xor Left.B1; - end loop; - - when Iir_Predefined_TF_Array_Element_Nand => - Eval_Right; - Result := Unshare (Left, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 and Right.B1); - end loop; - when Iir_Predefined_TF_Element_Array_Nand => - Eval_Right; - Result := Unshare (Right, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 and Left.B1); - end loop; - - when Iir_Predefined_TF_Array_Element_Nor => - Eval_Right; - Result := Unshare (Left, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 or Right.B1); - end loop; - when Iir_Predefined_TF_Element_Array_Nor => - Eval_Right; - Result := Unshare (Right, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 or Left.B1); - end loop; - - when Iir_Predefined_TF_Array_Element_Xnor => - Eval_Right; - Result := Unshare (Left, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 xor Right.B1); - end loop; - when Iir_Predefined_TF_Element_Array_Xnor => - Eval_Right; - Result := Unshare (Right, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := - not (Result.Val_Array.V (I).B1 xor Left.B1); - end loop; - - when Iir_Predefined_TF_Array_Not => - -- Need to copy as the result is modified. - Result := Unshare (Operand, Expr_Pool'Access); - for I in Result.Val_Array.V'Range loop - Result.Val_Array.V (I).B1 := not Result.Val_Array.V (I).B1; - end loop; - - when Iir_Predefined_TF_Reduction_And => - Result := Create_B1_Value (True); - for I in Operand.Val_Array.V'Range loop - Result.B1 := Result.B1 and Operand.Val_Array.V (I).B1; - end loop; - when Iir_Predefined_TF_Reduction_Nand => - Result := Create_B1_Value (True); - for I in Operand.Val_Array.V'Range loop - Result.B1 := Result.B1 and Operand.Val_Array.V (I).B1; - end loop; - Result.B1 := not Result.B1; - when Iir_Predefined_TF_Reduction_Or => - Result := Create_B1_Value (False); - for I in Operand.Val_Array.V'Range loop - Result.B1 := Result.B1 or Operand.Val_Array.V (I).B1; - end loop; - when Iir_Predefined_TF_Reduction_Nor => - Result := Create_B1_Value (False); - for I in Operand.Val_Array.V'Range loop - Result.B1 := Result.B1 or Operand.Val_Array.V (I).B1; - end loop; - Result.B1 := not Result.B1; - when Iir_Predefined_TF_Reduction_Xor => - Result := Create_B1_Value (False); - for I in Operand.Val_Array.V'Range loop - Result.B1 := Result.B1 xor Operand.Val_Array.V (I).B1; - end loop; - when Iir_Predefined_TF_Reduction_Xnor => - Result := Create_B1_Value (False); - for I in Operand.Val_Array.V'Range loop - Result.B1 := Result.B1 xor Operand.Val_Array.V (I).B1; - end loop; - Result.B1 := not Result.B1; - - when Iir_Predefined_Bit_Rising_Edge - | Iir_Predefined_Boolean_Rising_Edge => - return Boolean_To_Lit - (Execute_Event_Attribute (Operand) - and then Execute_Signal_Value (Operand).B1 = True); - when Iir_Predefined_Bit_Falling_Edge - | Iir_Predefined_Boolean_Falling_Edge => - return Boolean_To_Lit - (Execute_Event_Attribute (Operand) - and then Execute_Signal_Value (Operand).B1 = False); - - when Iir_Predefined_Array_Greater => - Eval_Right; - Result := Boolean_To_Lit (Compare_Value (Left, Right) = Greater); - - when Iir_Predefined_Array_Greater_Equal => - Eval_Right; - Result := Boolean_To_Lit (Compare_Value (Left, Right) >= Equal); - - when Iir_Predefined_Array_Less => - Eval_Right; - Result := Boolean_To_Lit (Compare_Value (Left, Right) = Less); - - when Iir_Predefined_Array_Less_Equal => - Eval_Right; - Result := Boolean_To_Lit (Compare_Value (Left, Right) <= Equal); - - when Iir_Predefined_Array_Minimum => - Eval_Right; - if Compare_Value (Left, Right) = Less then - Result := Left; - else - Result := Right; - end if; - when Iir_Predefined_Array_Maximum => - Eval_Right; - if Compare_Value (Left, Right) = Less then - Result := Right; - else - Result := Left; - end if; - - when Iir_Predefined_Vector_Maximum => - declare - El_St : constant Iir := - Get_Return_Type (Get_Implementation (Expr)); - V : Iir_Value_Literal_Acc; - begin - Result := Execute_Low_Limit (Execute_Bounds (Block, El_St)); - for I in Left.Val_Array.V'Range loop - V := Left.Val_Array.V (I); - if Compare_Value (V, Result) = Greater then - Result := V; - end if; - end loop; - end; - when Iir_Predefined_Vector_Minimum => - declare - El_St : constant Iir := - Get_Return_Type (Get_Implementation (Expr)); - V : Iir_Value_Literal_Acc; - begin - Result := Execute_High_Limit (Execute_Bounds (Block, El_St)); - for I in Left.Val_Array.V'Range loop - V := Left.Val_Array.V (I); - if Compare_Value (V, Result) = Less then - Result := V; - end if; - end loop; - end; - - when Iir_Predefined_Endfile => - Result := Boolean_To_Lit (File_Operation.Endfile (Left, Null_Iir)); - - when Iir_Predefined_Now_Function => - Result := Create_I64_Value (Ghdl_I64 (Grt.Types.Current_Time)); - - when Iir_Predefined_Integer_To_String - | Iir_Predefined_Floating_To_String - | Iir_Predefined_Physical_To_String => - Result := String_To_Iir_Value - (Execute_Image_Attribute (Left, Get_Type (Left_Param))); - - when Iir_Predefined_Enum_To_String => - declare - use Name_Table; - Base_Type : constant Iir := - Get_Base_Type (Get_Type (Left_Param)); - Lits : constant Iir_Flist := - Get_Enumeration_Literal_List (Base_Type); - Pos : constant Natural := Get_Enum_Pos (Left); - Id : Name_Id; - begin - if Base_Type = Std_Package.Character_Type_Definition then - Result := String_To_Iir_Value ((1 => Character'Val (Pos))); - else - Id := Get_Identifier (Get_Nth_Element (Lits, Pos)); - if Is_Character (Id) then - Result := String_To_Iir_Value ((1 => Get_Character (Id))); - else - Image (Id); - if Nam_Buffer (1) = '\' then - -- Reformat extended identifiers for to_image. - pragma Assert (Nam_Buffer (Nam_Length) = '\'); - declare - Npos : Natural; - K : Natural; - C : Character; - begin - Npos := 1; - K := 2; - while K < Nam_Length loop - C := Nam_Buffer (K); - Nam_Buffer (Npos) := C; - Npos := Npos + 1; - if C = '\' then - K := K + 2; - else - K := K + 1; - end if; - end loop; - Nam_Length := Npos - 1; - end; - end if; - Result := - String_To_Iir_Value (Nam_Buffer (1 .. Nam_Length)); - end if; - end if; - end; - - when Iir_Predefined_Array_Char_To_String => - declare - Lits : constant Iir_Flist := - Get_Enumeration_Literal_List - (Get_Base_Type - (Get_Element_Subtype (Get_Type (Left_Param)))); - Str : String (1 .. Natural (Left.Bounds.D (1).Length)); - Pos : Natural; - begin - for I in Left.Val_Array.V'Range loop - Pos := Get_Enum_Pos (Left.Val_Array.V (I)); - Str (Positive (I)) := Name_Table.Get_Character - (Get_Identifier (Get_Nth_Element (Lits, Pos))); - end loop; - Result := String_To_Iir_Value (Str); - end; - - when Iir_Predefined_Bit_Vector_To_Hstring => - return Execute_Bit_Vector_To_String (Left, 4); - - when Iir_Predefined_Bit_Vector_To_Ostring => - return Execute_Bit_Vector_To_String (Left, 3); - - when Iir_Predefined_Real_To_String_Digits => - Eval_Right; - declare - Str : Grt.Vstrings.String_Real_Format; - Last : Natural; - begin - Grt.Vstrings.To_String - (Str, Last, Left.F64, Ghdl_I32 (Right.I64)); - Result := String_To_Iir_Value (Str (1 .. Last)); - end; - when Iir_Predefined_Real_To_String_Format => - Eval_Right; - declare - Format : String (1 .. Natural (Right.Val_Array.Len) + 1); - Str : Grt.Vstrings.String_Real_Format; - Last : Natural; - begin - for I in Right.Val_Array.V'Range loop - Format (Positive (I)) := - Character'Val (Right.Val_Array.V (I).E8); - end loop; - Format (Format'Last) := ASCII.NUL; - Grt.Vstrings.To_String - (Str, Last, Left.F64, To_Ghdl_C_String (Format'Address)); - Result := String_To_Iir_Value (Str (1 .. Last)); - end; - when Iir_Predefined_Time_To_String_Unit => - Eval_Right; - declare - Str : Grt.Vstrings.String_Time_Unit; - First : Natural; - Unit : Iir; - begin - Unit := Get_Unit_Chain (Std_Package.Time_Type_Definition); - while Unit /= Null_Iir loop - exit when Evaluation.Get_Physical_Value (Unit) - = Iir_Int64 (Right.I64); - Unit := Get_Chain (Unit); - end loop; - if Unit = Null_Iir then - Error_Msg_Exec - ("to_string for time called with wrong unit", Expr); - end if; - Grt.Vstrings.To_String (Str, First, Left.I64, Right.I64); - Result := String_To_Iir_Value - (Str (First .. Str'Last) & ' ' - & Name_Table.Image (Get_Identifier (Unit))); - end; - - when Iir_Predefined_Std_Ulogic_Match_Equality => - Eval_Right; - declare - use Grt.Std_Logic_1164; - begin - Result := Create_E8_Value - (Std_Ulogic'Pos - (Match_Eq_Table (Std_Ulogic'Val (Left.E8), - Std_Ulogic'Val (Right.E8)))); - end; - when Iir_Predefined_Std_Ulogic_Match_Inequality => - Eval_Right; - declare - use Grt.Std_Logic_1164; - begin - Result := Create_E8_Value - (Std_Ulogic'Pos - (Not_Table (Match_Eq_Table (Std_Ulogic'Val (Left.E8), - Std_Ulogic'Val (Right.E8))))); - end; - when Iir_Predefined_Std_Ulogic_Match_Ordering_Functions => - Eval_Right; - declare - use Grt.Std_Logic_1164; - L : constant Std_Ulogic := Std_Ulogic'Val (Left.E8); - R : constant Std_Ulogic := Std_Ulogic'Val (Right.E8); - Res : Std_Ulogic; - begin - Check_Std_Ulogic_Dc (Expr, L); - Check_Std_Ulogic_Dc (Expr, R); - case Iir_Predefined_Std_Ulogic_Match_Ordering_Functions (Func) - is - when Iir_Predefined_Std_Ulogic_Match_Less => - Res := Match_Lt_Table (L, R); - when Iir_Predefined_Std_Ulogic_Match_Less_Equal => - Res := Or_Table (Match_Lt_Table (L, R), - Match_Eq_Table (L, R)); - when Iir_Predefined_Std_Ulogic_Match_Greater => - Res := Not_Table (Or_Table (Match_Lt_Table (L, R), - Match_Eq_Table (L, R))); - when Iir_Predefined_Std_Ulogic_Match_Greater_Equal => - Res := Not_Table (Match_Lt_Table (L, R)); - end case; - Result := Create_E8_Value (Std_Ulogic'Pos (Res)); - end; - - when Iir_Predefined_Std_Ulogic_Array_Match_Equality - | Iir_Predefined_Std_Ulogic_Array_Match_Inequality => - Eval_Right; - if Left.Bounds.D (1).Length /= Right.Bounds.D (1).Length then - Error_Msg_Constraint (Expr); - end if; - declare - use Grt.Std_Logic_1164; - Res : Std_Ulogic := '1'; - Le, Re : Std_Ulogic; - Has_Match_Err : Boolean; - begin - Has_Match_Err := False; - for I in Left.Val_Array.V'Range loop - Le := Std_Ulogic'Val (Left.Val_Array.V (I).E8); - Re := Std_Ulogic'Val (Right.Val_Array.V (I).E8); - if (Le = '-' or Re = '-') and then not Has_Match_Err then - Assert_Std_Ulogic_Dc (Expr); - Has_Match_Err := True; - end if; - Res := And_Table (Res, Match_Eq_Table (Le, Re)); - end loop; - if Func = Iir_Predefined_Std_Ulogic_Array_Match_Inequality then - Res := Not_Table (Res); - end if; - Result := Create_E8_Value (Std_Ulogic'Pos (Res)); - end; - - when others => - Error_Msg_Elab (Expr, "execute_implicit_function: unimplemented " & - Iir_Predefined_Functions'Image (Func)); - raise Internal_Error; - end case; - return Result; - exception - when Constraint_Error => - Error_Msg_Constraint (Expr); - end Execute_Implicit_Function; - - procedure Execute_Implicit_Procedure - (Block: Block_Instance_Acc; Stmt: Iir_Procedure_Call) - is - Imp : constant Iir := Get_Implementation (Stmt); - Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); - Assoc: Iir; - Args: Iir_Value_Literal_Array (0 .. 3); - Inter_Chain : Iir; - Expr_Mark : Mark_Type; - begin - Mark (Expr_Mark, Expr_Pool); - Assoc := Assoc_Chain; - for I in Iir_Index32 loop - exit when Assoc = Null_Iir; - Args (I) := Execute_Expression (Block, Get_Actual (Assoc)); - Assoc := Get_Chain (Assoc); - end loop; - Inter_Chain := Get_Interface_Declaration_Chain (Imp); - case Get_Implicit_Definition (Imp) is - when Iir_Predefined_Deallocate => - if Args (0).Val_Access /= null then - Free_Heap_Value (Args (0)); - Args (0).Val_Access := null; - end if; - when Iir_Predefined_File_Open => - File_Operation.File_Open - (Args (0), Args (1), Args (2), Inter_Chain, Stmt); - when Iir_Predefined_File_Open_Status => - File_Operation.File_Open_Status - (Args (0), Args (1), Args (2), Args (3), - Get_Chain (Inter_Chain), Stmt); - when Iir_Predefined_Write => - if Get_Text_File_Flag (Get_Type (Inter_Chain)) then - File_Operation.Write_Text (Args (0), Args (1)); - else - File_Operation.Write_Binary (Args (0), Args (1)); - end if; - when Iir_Predefined_Read_Length => - if Get_Text_File_Flag (Get_Type (Inter_Chain)) then - File_Operation.Read_Length_Text - (Args (0), Args (1), Args (2)); - else - File_Operation.Read_Length_Binary - (Args (0), Args (1), Args (2)); - end if; - when Iir_Predefined_Read => - File_Operation.Read_Binary (Args (0), Args (1)); - when Iir_Predefined_Flush => - File_Operation.Flush (Args (0)); - when Iir_Predefined_File_Close => - if Get_Text_File_Flag (Get_Type (Inter_Chain)) then - File_Operation.File_Close_Text (Args (0), Stmt); - else - File_Operation.File_Close_Binary (Args (0), Stmt); - end if; - when others => - Error_Kind ("execute_implicit_procedure", - Get_Implicit_Definition (Imp)); - end case; - Release (Expr_Mark, Expr_Pool); - end Execute_Implicit_Procedure; - - procedure Execute_Foreign_Procedure - (Block: Block_Instance_Acc; Stmt: Iir_Procedure_Call) - is - Imp : constant Iir := Get_Implementation (Stmt); - Assoc_Chain : constant Iir := Get_Parameter_Association_Chain (Stmt); - Assoc: Iir; - Args: Iir_Value_Literal_Array (0 .. 3) := (others => null); - Expr_Mark : Mark_Type; - begin - Mark (Expr_Mark, Expr_Pool); - Assoc := Assoc_Chain; - for I in Args'Range loop - exit when Assoc = Null_Iir; - Args (I) := Execute_Expression (Block, Get_Actual (Assoc)); - Assoc := Get_Chain (Assoc); - end loop; - case Get_Identifier (Imp) is - when Std_Names.Name_Untruncated_Text_Read => - File_Operation.Untruncated_Text_Read - (Args (0), Args (1), Args (2)); - when Std_Names.Name_Control_Simulation => - Grt.Lib.Ghdl_Control_Simulation - (Args (0).B1, Args (1).B1, Std_Integer (Args (2).I64)); - -- Do not return. - when Std_Names.Name_Textio_Write_Real => - File_Operation.Textio_Write_Real - (Args (0), Args (1), Args (2).F64, Std_Integer (Args (3).I64)); - when others => - Error_Msg_Exec ("unsupported foreign procedure call", Stmt); - end case; - Release (Expr_Mark, Expr_Pool); - end Execute_Foreign_Procedure; - - -- Compute the offset for INDEX into a range BOUNDS. - -- EXPR is only used in case of error. - function Get_Index_Offset - (Index: Iir_Value_Literal_Acc; - Bounds: Iir_Value_Literal_Acc; - Expr: Iir) - return Iir_Index32 - is - Left_Pos, Right_Pos: Iir_Value_Literal_Acc; - begin - Left_Pos := Bounds.Left; - Right_Pos := Bounds.Right; - if Index.Kind /= Left_Pos.Kind or else Index.Kind /= Right_Pos.Kind then - raise Internal_Error; - end if; - case Iir_Value_Discrete (Index.Kind) is - when Iir_Value_B1 => - case Bounds.Dir is - when Iir_To => - if Index.B1 >= Left_Pos.B1 and then - Index.B1 <= Right_Pos.B1 - then - -- to - return Ghdl_B1'Pos (Index.B1) - Ghdl_B1'Pos (Left_Pos.B1); - end if; - when Iir_Downto => - if Index.B1 <= Left_Pos.B1 and then - Index.B1 >= Right_Pos.B1 - then - -- downto - return Ghdl_B1'Pos (Left_Pos.B1) - Ghdl_B1'Pos (Index.B1); - end if; - end case; - when Iir_Value_E8 => - case Bounds.Dir is - when Iir_To => - if Index.E8 >= Left_Pos.E8 and then - Index.E8 <= Right_Pos.E8 - then - -- to - return Iir_Index32 (Index.E8 - Left_Pos.E8); - end if; - when Iir_Downto => - if Index.E8 <= Left_Pos.E8 and then - Index.E8 >= Right_Pos.E8 - then - -- downto - return Iir_Index32 (Left_Pos.E8 - Index.E8); - end if; - end case; - when Iir_Value_E32 => - case Bounds.Dir is - when Iir_To => - if Index.E32 >= Left_Pos.E32 and then - Index.E32 <= Right_Pos.E32 - then - -- to - return Iir_Index32 (Index.E32 - Left_Pos.E32); - end if; - when Iir_Downto => - if Index.E32 <= Left_Pos.E32 and then - Index.E32 >= Right_Pos.E32 - then - -- downto - return Iir_Index32 (Left_Pos.E32 - Index.E32); - end if; - end case; - when Iir_Value_I64 => - case Bounds.Dir is - when Iir_To => - if Index.I64 >= Left_Pos.I64 and then - Index.I64 <= Right_Pos.I64 - then - -- to - return Iir_Index32 (Index.I64 - Left_Pos.I64); - end if; - when Iir_Downto => - if Index.I64 <= Left_Pos.I64 and then - Index.I64 >= Right_Pos.I64 - then - -- downto - return Iir_Index32 (Left_Pos.I64 - Index.I64); - end if; - end case; - end case; - Error_Msg_Constraint (Expr); - return 0; - end Get_Index_Offset; - - -- Create an iir_value_literal of kind iir_value_array and of life LIFE. - -- Allocate the array of bounds, and fill it from A_TYPE. - -- Allocate the array of values. - function Create_Array_Bounds_From_Type - (Block : Block_Instance_Acc; - A_Type : Iir; - Create_Val_Array : Boolean) - return Iir_Value_Literal_Acc - is - -- Only for constrained subtypes. - pragma Assert (Get_Kind (A_Type) /= Iir_Kind_Array_Type_Definition); - - Index_List : constant Iir_Flist := Get_Index_Subtype_List (A_Type); - Res : Iir_Value_Literal_Acc; - Len : Iir_Index32; - Bound : Iir_Value_Literal_Acc; - begin - Res := Create_Array_Value - (Iir_Index32 (Get_Nbr_Elements (Index_List))); - Len := 1; - for I in 1 .. Res.Bounds.Nbr_Dims loop - Bound := Execute_Bounds - (Block, Get_Nth_Element (Index_List, Natural (I - 1))); - Len := Len * Bound.Length; - Res.Bounds.D (I) := Bound; - end loop; - if Create_Val_Array then - Create_Array_Data (Res, Len); - end if; - return Res; - end Create_Array_Bounds_From_Type; - - -- Return the steps (ie, offset in the array when index DIM is increased - -- by one) for array ARR and dimension DIM. - function Get_Step_For_Dim (Arr: Iir_Value_Literal_Acc; Dim : Natural) - return Iir_Index32 - is - Bounds : Value_Bounds_Array_Acc renames Arr.Bounds; - Res : Iir_Index32; - begin - Res := 1; - for I in Iir_Index32 (Dim + 1) .. Bounds.Nbr_Dims loop - Res := Res * Bounds.D (I).Length; - end loop; - return Res; - end Get_Step_For_Dim; - - -- Create a literal for a string or a bit_string - function String_To_Enumeration_Array_1 (Str: Iir; El_Type : Iir) - return Iir_Value_Literal_Acc - is - pragma Assert (Get_Kind (Str) = Iir_Kind_String_Literal8); - Id : constant String8_Id := Get_String8_Id (Str); - Len : constant Iir_Index32 := Iir_Index32 (Get_String_Length (Str)); - - El_Btype : constant Iir := Get_Base_Type (El_Type); - - Lit: Iir_Value_Literal_Acc; - El : Iir_Value_Literal_Acc; - Element_Mode : Iir_Value_Scalars; - - Pos : Nat8; - begin - Element_Mode := Get_Info (El_Btype).Scalar_Mode; - - Lit := Create_Array_Value (Len, 1); - - for I in Lit.Val_Array.V'Range loop - -- FIXME: use literal from type ?? - Pos := Str_Table.Element_String8 (Id, Pos32 (I)); - case Element_Mode is - when Iir_Value_B1 => - El := Create_B1_Value (Ghdl_B1'Val (Pos)); - when Iir_Value_E8 => - El := Create_E8_Value (Ghdl_E8'Val (Pos)); - when Iir_Value_E32 => - El := Create_E32_Value (Ghdl_E32'Val (Pos)); - when others => - raise Internal_Error; - end case; - Lit.Val_Array.V (I) := El; - end loop; - - return Lit; - end String_To_Enumeration_Array_1; - - -- Create a literal for a string or a bit_string - function String_To_Enumeration_Array (Block: Block_Instance_Acc; Str: Iir) - return Iir_Value_Literal_Acc - is - Array_Type: constant Iir := Get_Type (Str); - Index_Types : constant Iir_Flist := Get_Index_Subtype_List (Array_Type); - Res : Iir_Value_Literal_Acc; - begin - -- Array must be unidimensional. - pragma Assert (Get_Nbr_Elements (Index_Types) = 1); - - Res := String_To_Enumeration_Array_1 - (Str, Get_Element_Subtype (Array_Type)); - - -- When created from static evaluation, a string may still have an - -- unconstrained type. - if Get_Constraint_State (Array_Type) /= Fully_Constrained then - Res.Bounds.D (1) := - Create_Range_Value (Create_I64_Value (1), - Create_I64_Value (Ghdl_I64 (Res.Val_Array.Len)), - Iir_To, - Res.Val_Array.Len); - else - Res.Bounds.D (1) := - Execute_Bounds (Block, Get_Nth_Element (Index_Types, 0)); - end if; - - -- The range may not be statically constant. - if Res.Bounds.D (1).Length /= Res.Val_Array.Len then - Error_Msg_Constraint (Str); - end if; - - return Res; - end String_To_Enumeration_Array; - - -- Fill LENGTH elements of RES, starting at ORIG by steps of STEP. - -- Use expressions from (BLOCK, AGGREGATE) to fill the elements. - -- EL_TYPE is the type of the array element. - procedure Fill_Array_Aggregate_1 - (Block : Block_Instance_Acc; - Aggregate : Iir; - Res : Iir_Value_Literal_Acc; - Orig : Iir_Index32; - Step : Iir_Index32; - Dim : Iir_Index32; - Nbr_Dim : Iir_Index32; - El_Type : Iir) - is - Value : Iir; - Bound : constant Iir_Value_Literal_Acc := Res.Bounds.D (Dim); - - procedure Set_Elem (Pos : Iir_Index32) - is - Val : Iir_Value_Literal_Acc; - begin - if Dim = Nbr_Dim then - -- VALUE is an expression (which may be an aggregate, but not - -- a sub-aggregate. - Val := Execute_Expression_With_Type (Block, Value, El_Type); - -- LRM93 7.3.2.2 - -- For a multi-dimensional aggregate of dimension n, a check - -- is made that all (n-1)-dimensional subaggregates have the - -- same bounds. - -- GHDL: I have added an implicit array conversion, however - -- it may be useful to allow cases like this: - -- type str_array is array (natural range <>) - -- of string (10 downto 1); - -- constant floats : str_array := - -- ( "00000000.0", HT & "+1.5ABCDE"); - -- The subtype of the first sub-aggregate (0.0) is - -- determinated by the context, according to rule 9 and 4 - -- of LRM93 7.3.2.2 and therefore is string (10 downto 1), - -- while the subtype of the second sub-aggregate (HT & ...) - -- is determinated by rules 1 and 2 of LRM 7.2.4, and is - -- string (1 to 10). - -- Unless an implicit conversion is used, according to the - -- LRM, this should fail, but it makes no sens. - -- - -- FIXME: Add a warning, a flag ? - --Implicit_Array_Conversion (Block, Val, El_Type, Value); - --Check_Constraints (Block, Val, El_Type, Value); - Res.Val_Array.V (1 + Orig + Pos * Step) := Val; - else - case Get_Kind (Value) is - when Iir_Kind_Aggregate => - -- VALUE is a sub-aggregate. - Fill_Array_Aggregate_1 (Block, Value, Res, - Orig + Pos * Step, - Step / Res.Bounds.D (Dim + 1).Length, - Dim + 1, Nbr_Dim, El_Type); - when Iir_Kind_String_Literal8 => - pragma Assert (Dim + 1 = Nbr_Dim); - Val := String_To_Enumeration_Array_1 (Value, El_Type); - if Val.Val_Array.Len /= Res.Bounds.D (Nbr_Dim).Length then - Error_Msg_Constraint (Value); - end if; - for I in Val.Val_Array.V'Range loop - Res.Val_Array.V (Orig + Pos * Step + I) := - Val.Val_Array.V (I); - end loop; - when others => - Error_Kind ("fill_array_aggregate_1", Value); - end case; - end if; - end Set_Elem; - - procedure Set_Elem_By_Expr (Expr : Iir) - is - Expr_Pos: Iir_Value_Literal_Acc; - begin - Expr_Pos := Execute_Expression (Block, Expr); - Set_Elem (Get_Index_Offset (Expr_Pos, Bound, Expr)); - end Set_Elem_By_Expr; - - procedure Set_Elem_By_Range (Expr : Iir) - is - A_Range : Iir_Value_Literal_Acc; - High, Low : Iir_Value_Literal_Acc; - begin - A_Range := Execute_Bounds (Block, Expr); - if Is_Null_Range (A_Range) then - return; - end if; - if A_Range.Dir = Iir_To then - High := A_Range.Right; - Low := A_Range.Left; - else - High := A_Range.Left; - Low := A_Range.Right; - end if; - - -- Locally modified (incremented) - Low := Unshare (Low, Expr_Pool'Access); - - loop - Set_Elem (Get_Index_Offset (Low, Bound, Expr)); - exit when Is_Equal (Low, High); - Increment (Low); - end loop; - end Set_Elem_By_Range; - - Length : constant Iir_Index32 := Bound.Length; - Assoc : Iir; - Pos : Iir_Index32; - begin - Assoc := Get_Association_Choices_Chain (Aggregate); - Pos := 0; - while Assoc /= Null_Iir loop - Value := Get_Associated_Expr (Assoc); - loop - case Get_Kind (Assoc) is - when Iir_Kind_Choice_By_None => - if Pos >= Length then - Error_Msg_Constraint (Assoc); - end if; - Set_Elem (Pos); - Pos := Pos + 1; - when Iir_Kind_Choice_By_Expression => - Set_Elem_By_Expr (Get_Choice_Expression (Assoc)); - when Iir_Kind_Choice_By_Range => - Set_Elem_By_Range (Get_Choice_Range (Assoc)); - when Iir_Kind_Choice_By_Others => - for J in 1 .. Length loop - if Res.Val_Array.V (Orig + J * Step) = null then - Set_Elem (J - 1); - end if; - end loop; - return; - when others => - raise Internal_Error; - end case; - Assoc := Get_Chain (Assoc); - exit when Assoc = Null_Iir; - exit when not Get_Same_Alternative_Flag (Assoc); - end loop; - end loop; - - -- Check each elements have been set. - -- FIXME: check directly with type. - for J in 1 .. Length loop - if Res.Val_Array.V (Orig + J * Step) = null then - Error_Msg_Constraint (Aggregate); - end if; - end loop; - end Fill_Array_Aggregate_1; - - -- Use expressions from (BLOCK, AGGREGATE) to fill RES. - procedure Fill_Array_Aggregate - (Block : Block_Instance_Acc; - Aggregate : Iir; - Res : Iir_Value_Literal_Acc) - is - Aggr_Type : constant Iir := Get_Type (Aggregate); - El_Type : constant Iir := Get_Element_Subtype (Aggr_Type); - Index_List : constant Iir_Flist := Get_Index_Subtype_List (Aggr_Type); - Nbr_Dim : constant Iir_Index32 := - Iir_Index32 (Get_Nbr_Elements (Index_List)); - Step : Iir_Index32; - begin - Step := Get_Step_For_Dim (Res, 1); - Fill_Array_Aggregate_1 - (Block, Aggregate, Res, 0, Step, 1, Nbr_Dim, El_Type); - end Fill_Array_Aggregate; - - function Execute_Record_Aggregate (Block: Block_Instance_Acc; - Aggregate: Iir; - Aggregate_Type: Iir) - return Iir_Value_Literal_Acc - is - List : constant Iir_Flist := - Get_Elements_Declaration_List (Get_Base_Type (Aggregate_Type)); - - Res: Iir_Value_Literal_Acc; - Expr : Iir; - - procedure Set_Expr (Pos : Iir_Index32) is - El : constant Iir := Get_Nth_Element (List, Natural (Pos - 1)); - begin - Res.Val_Record.V (Pos) := - Execute_Expression_With_Type (Block, Expr, Get_Type (El)); - end Set_Expr; - - Pos : Iir_Index32; - Assoc: Iir; - N_Expr : Iir; - begin - Res := Create_Record_Value (Iir_Index32 (Get_Nbr_Elements (List))); - - Assoc := Get_Association_Choices_Chain (Aggregate); - Pos := 1; - loop - N_Expr := Get_Associated_Expr (Assoc); - if N_Expr /= Null_Iir then - Expr := N_Expr; - end if; - case Get_Kind (Assoc) is - when Iir_Kind_Choice_By_None => - Set_Expr (Pos); - Pos := Pos + 1; - when Iir_Kind_Choice_By_Name => - Set_Expr (1 + Get_Element_Position - (Get_Named_Entity (Get_Choice_Name (Assoc)))); - when Iir_Kind_Choice_By_Others => - for I in Res.Val_Record.V'Range loop - if Res.Val_Record.V (I) = null then - Set_Expr (I); - end if; - end loop; - when others => - Error_Kind ("execute_record_aggregate", Assoc); - end case; - Assoc := Get_Chain (Assoc); - exit when Assoc = Null_Iir; - end loop; - return Res; - end Execute_Record_Aggregate; - - function Execute_Aggregate (Block: Block_Instance_Acc; - Aggregate: Iir; - Aggregate_Type: Iir) - return Iir_Value_Literal_Acc is - begin - case Get_Kind (Aggregate_Type) is - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Array_Subtype_Definition => - declare - Res : Iir_Value_Literal_Acc; - begin - Res := Create_Array_Bounds_From_Type - (Block, Aggregate_Type, True); - Fill_Array_Aggregate (Block, Aggregate, Res); - return Res; - end; - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - return Execute_Record_Aggregate - (Block, Aggregate, Aggregate_Type); - when others => - Error_Kind ("execute_aggregate", Aggregate_Type); - end case; - end Execute_Aggregate; - - function Execute_Simple_Aggregate (Block: Block_Instance_Acc; Aggr : Iir) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - List : constant Iir_Flist := Get_Simple_Aggregate_List (Aggr); - begin - Res := Create_Array_Bounds_From_Type (Block, Get_Type (Aggr), True); - for I in Res.Val_Array.V'Range loop - Res.Val_Array.V (I) := - Execute_Expression (Block, Get_Nth_Element (List, Natural (I - 1))); - end loop; - return Res; - end Execute_Simple_Aggregate; - - -- Fill LENGTH elements of RES, starting at ORIG by steps of STEP. - -- Use expressions from (BLOCK, AGGREGATE) to fill the elements. - -- EL_TYPE is the type of the array element. - procedure Execute_Name_Array_Aggregate - (Block : Block_Instance_Acc; - Aggregate : Iir; - Res : Iir_Value_Literal_Acc; - Orig : Iir_Index32; - Step : Iir_Index32; - Dim : Iir_Index32; - Nbr_Dim : Iir_Index32; - El_Type : Iir) - is - Value : Iir; - Bound : Iir_Value_Literal_Acc; - - procedure Set_Elem (Pos : Iir_Index32) - is - Val : Iir_Value_Literal_Acc; - Is_Sig : Boolean; - begin - if Dim = Nbr_Dim then - -- VALUE is an expression (which may be an aggregate, but not - -- a sub-aggregate. - Execute_Name_With_Base (Block, Value, null, Val, Is_Sig); - Res.Val_Array.V (1 + Orig + Pos * Step) := Val; - else - -- VALUE is a sub-aggregate. - Execute_Name_Array_Aggregate - (Block, Value, Res, - Orig + Pos * Step, - Step / Res.Bounds.D (Dim + 1).Length, - Dim + 1, Nbr_Dim, El_Type); - end if; - end Set_Elem; - - Assoc : Iir; - Pos : Iir_Index32; - begin - Assoc := Get_Association_Choices_Chain (Aggregate); - Bound := Res.Bounds.D (Dim); - Pos := 0; - while Assoc /= Null_Iir loop - Value := Get_Associated_Expr (Assoc); - case Get_Kind (Assoc) is - when Iir_Kind_Choice_By_None => - null; - when Iir_Kind_Choice_By_Expression => - declare - Expr_Pos: Iir_Value_Literal_Acc; - Val : constant Iir := Get_Expression (Assoc); - begin - Expr_Pos := Execute_Expression (Block, Val); - Pos := Get_Index_Offset (Expr_Pos, Bound, Val); - end; - when others => - raise Internal_Error; - end case; - Set_Elem (Pos); - Pos := Pos + 1; - Assoc := Get_Chain (Assoc); - end loop; - end Execute_Name_Array_Aggregate; - - function Execute_Record_Name_Aggregate - (Block: Block_Instance_Acc; - Aggregate: Iir; - Aggregate_Type: Iir) - return Iir_Value_Literal_Acc - is - List : constant Iir_Flist := - Get_Elements_Declaration_List (Get_Base_Type (Aggregate_Type)); - Res: Iir_Value_Literal_Acc; - Expr : Iir; - Pos : Iir_Index32; - El_Pos : Iir_Index32; - Is_Sig : Boolean; - Assoc: Iir; - begin - Res := Create_Record_Value (Iir_Index32 (Get_Nbr_Elements (List))); - Assoc := Get_Association_Choices_Chain (Aggregate); - Pos := 0; - loop - Expr := Get_Associated_Expr (Assoc); - if Expr = Null_Iir then - -- List of choices is not allowed. - raise Internal_Error; - end if; - case Get_Kind (Assoc) is - when Iir_Kind_Choice_By_None => - El_Pos := Pos; - Pos := Pos + 1; - when Iir_Kind_Choice_By_Name => - El_Pos := Get_Element_Position (Get_Name (Assoc)); - when Iir_Kind_Choice_By_Others => - raise Internal_Error; - when others => - Error_Kind ("execute_record_name_aggregate", Assoc); - end case; - Execute_Name_With_Base - (Block, Expr, null, Res.Val_Record.V (1 + El_Pos), Is_Sig); - Assoc := Get_Chain (Assoc); - exit when Assoc = Null_Iir; - end loop; - return Res; - end Execute_Record_Name_Aggregate; - - function Execute_Name_Aggregate - (Block: Block_Instance_Acc; - Aggregate: Iir; - Aggregate_Type: Iir) - return Iir_Value_Literal_Acc - is - begin - case Get_Kind (Aggregate_Type) is - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Array_Subtype_Definition => - declare - El_Type : constant Iir := Get_Element_Subtype (Aggregate_Type); - Index_List : constant Iir_Flist := - Get_Index_Subtype_List (Aggregate_Type); - Nbr_Dim : constant Iir_Index32 := - Iir_Index32 (Get_Nbr_Elements (Index_List)); - Res : Iir_Value_Literal_Acc; - Step : Iir_Index32; - begin - Res := Create_Array_Bounds_From_Type - (Block, Aggregate_Type, True); - Step := Get_Step_For_Dim (Res, 1); - Execute_Name_Array_Aggregate - (Block, Aggregate, Res, 0, Step, 1, Nbr_Dim, El_Type); - return Res; - end; - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - return Execute_Record_Name_Aggregate - (Block, Aggregate, Aggregate_Type); - when others => - Error_Kind ("execute_name_aggregate", Aggregate_Type); - end case; - end Execute_Name_Aggregate; - - -- Return the indexes range for prefix of ATTR. - function Execute_Indexes (Block: Block_Instance_Acc; Attr : Iir) - return Iir_Value_Literal_Acc - is - Prefix : constant Iir := Strip_Denoting_Name (Get_Prefix (Attr)); - Dim : constant Natural := - Evaluation.Eval_Attribute_Parameter_Or_1 (Attr); - begin - case Get_Kind (Prefix) is - when Iir_Kind_Type_Declaration - | Iir_Kind_Subtype_Declaration => - declare - Index : Iir; - begin - Index := Get_Nth_Element - (Get_Index_Subtype_List (Get_Type (Prefix)), Dim - 1); - return Execute_Bounds (Block, Index); - end; - when Iir_Kind_Array_Type_Definition - | Iir_Kind_Array_Subtype_Definition => - Error_Kind ("execute_indexes", Prefix); - when others => - declare - Orig : Iir_Value_Literal_Acc; - begin - Orig := Execute_Name (Block, Prefix, True); - return Orig.Bounds.D (Iir_Index32 (Dim)); - end; - end case; - end Execute_Indexes; - - function Execute_Bounds (Block: Block_Instance_Acc; Prefix: Iir) - return Iir_Value_Literal_Acc - is - Bound : Iir_Value_Literal_Acc; - begin - case Get_Kind (Prefix) is - when Iir_Kind_Range_Expression => - declare - Info : constant Sim_Info_Acc := Get_Info (Prefix); - begin - if Info = null then - Bound := Create_Range_Value - (Execute_Expression (Block, Get_Left_Limit (Prefix)), - Execute_Expression (Block, Get_Right_Limit (Prefix)), - Get_Direction (Prefix)); - elsif Info.Kind = Kind_Object then - Bound := Get_Instance_For_Slot - (Block, Prefix).Objects (Info.Slot); - else - raise Internal_Error; - end if; - end; - - when Iir_Kind_Subtype_Declaration => - return Execute_Bounds (Block, Get_Type (Prefix)); - - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Physical_Subtype_Definition => - -- FIXME: move this block before and avoid recursion. - return Execute_Bounds (Block, Get_Range_Constraint (Prefix)); - - when Iir_Kind_Range_Array_Attribute => - Bound := Execute_Indexes (Block, Prefix); - when Iir_Kind_Reverse_Range_Array_Attribute => - Bound := Execute_Indexes (Block, Prefix); - case Bound.Dir is - when Iir_To => - Bound := Create_Range_Value - (Bound.Right, Bound.Left, Iir_Downto, Bound.Length); - when Iir_Downto => - Bound := Create_Range_Value - (Bound.Right, Bound.Left, Iir_To, Bound.Length); - end case; - - when Iir_Kind_Floating_Type_Definition - | Iir_Kind_Integer_Type_Definition => - return Execute_Bounds - (Block, - Get_Range_Constraint (Get_Type (Get_Type_Declarator (Prefix)))); - - when Iir_Kinds_Denoting_Name => - return Execute_Bounds (Block, Get_Named_Entity (Prefix)); - - when others => - -- Error_Kind ("execute_bounds", Get_Kind (Prefix)); - declare - Prefix_Val: Iir_Value_Literal_Acc; - begin - Prefix_Val := Execute_Expression (Block, Prefix); - Bound := Prefix_Val.Bounds.D (1); - end; - end case; - if not Bound.Dir'Valid then - raise Internal_Error; - end if; - return Bound; - end Execute_Bounds; - - -- Perform type conversion as desribed in LRM93 7.3.5 - function Execute_Type_Conversion (Block: Block_Instance_Acc; - Val : Iir_Value_Literal_Acc; - Target_Type : Iir; - Loc : Iir) - return Iir_Value_Literal_Acc - is - Res: Iir_Value_Literal_Acc; - begin - Res := Val; - case Get_Kind (Target_Type) is - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Integer_Subtype_Definition => - case Iir_Value_Numerics (Res.Kind) is - when Iir_Value_I64 => - null; - when Iir_Value_F64 => - if Res.F64 > Ghdl_F64 (Iir_Int64'Last) or - Res.F64 < Ghdl_F64 (Iir_Int64'First) - then - Error_Msg_Constraint (Loc); - end if; - Res := Create_I64_Value (Ghdl_I64 (Res.F64)); - end case; - when Iir_Kind_Floating_Type_Definition - | Iir_Kind_Floating_Subtype_Definition => - case Iir_Value_Numerics (Res.Kind) is - when Iir_Value_F64 => - null; - when Iir_Value_I64 => - Res := Create_F64_Value (Ghdl_F64 (Res.I64)); - end case; - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - -- Must be same type. - null; - when Iir_Kind_Physical_Type_Definition - | Iir_Kind_Physical_Subtype_Definition => - -- Same type. - null; - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - -- Same type. - null; - when Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Array_Type_Definition => - -- LRM93 7.3.5 - -- if the type mark denotes an unconstrained array type and the - -- operand is not a null array, then for each index position, the - -- bounds of the result are obtained by converting the bounds of - -- the operand to the corresponding index type of the target type. - -- - -- LRM93 7.3.5 - -- If the type mark denotes a constrained array subtype, then the - -- bounds of the result are those imposed by the type mark. - if Get_Constraint_State (Target_Type) = Fully_Constrained then - Implicit_Array_Conversion (Block, Res, Target_Type, Loc); - else - declare - Idx_List : constant Iir_Flist := - Get_Index_Subtype_List (Target_Type); - Idx_Type : Iir; - begin - Res := Create_Array_Value (Val.Bounds.Nbr_Dims); - Res.Val_Array := Val.Val_Array; - for I in Val.Bounds.D'Range loop - Idx_Type := Get_Index_Type (Idx_List, Natural (I - 1)); - Res.Bounds.D (I) := Create_Range_Value - (Left => Execute_Type_Conversion - (Block, Val.Bounds.D (I).Left, Idx_Type, Loc), - Right => Execute_Type_Conversion - (Block, Val.Bounds.D (I).Right, Idx_Type, Loc), - Dir => Val.Bounds.D (I).Dir, - Length => Val.Bounds.D (I).Length); - end loop; - end; - end if; - when others => - Error_Kind ("execute_type_conversion", Target_Type); - end case; - Check_Constraints (Block, Res, Target_Type, Loc); - return Res; - end Execute_Type_Conversion; - - -- Decrement VAL. - -- May raise a constraint error using EXPR. - function Execute_Dec (Val : Iir_Value_Literal_Acc; Expr : Iir) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - case Iir_Value_Discrete (Val.Kind) is - when Iir_Value_B1 => - if Val.B1 = False then - Error_Msg_Constraint (Expr); - end if; - Res := Create_B1_Value (False); - when Iir_Value_E8 => - if Val.E8 = 0 then - Error_Msg_Constraint (Expr); - end if; - Res := Create_E8_Value (Val.E8 - 1); - when Iir_Value_E32 => - if Val.E32 = 0 then - Error_Msg_Constraint (Expr); - end if; - Res := Create_E32_Value (Val.E32 - 1); - when Iir_Value_I64 => - if Val.I64 = Ghdl_I64'First then - Error_Msg_Constraint (Expr); - end if; - Res := Create_I64_Value (Val.I64 - 1); - end case; - return Res; - end Execute_Dec; - - -- Increment VAL. - -- May raise a constraint error using EXPR. - function Execute_Inc (Val : Iir_Value_Literal_Acc; Expr : Iir) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - case Iir_Value_Discrete (Val.Kind) is - when Iir_Value_B1 => - if Val.B1 = True then - Error_Msg_Constraint (Expr); - end if; - Res := Create_B1_Value (True); - when Iir_Value_E32 => - if Val.E32 = Ghdl_E32'Last then - Error_Msg_Constraint (Expr); - end if; - Res := Create_E32_Value (Val.E32 + 1); - when Iir_Value_E8 => - if Val.E8 = Ghdl_E8'Last then - Error_Msg_Constraint (Expr); - end if; - Res := Create_E8_Value (Val.E8 + 1); - when Iir_Value_I64 => - if Val.I64 = Ghdl_I64'Last then - Error_Msg_Constraint (Expr); - end if; - Res := Create_I64_Value (Val.I64 + 1); - end case; - return Res; - end Execute_Inc; - - function Execute_Expression_With_Type - (Block: Block_Instance_Acc; - Expr: Iir; - Expr_Type : Iir) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - if Get_Kind (Expr) = Iir_Kind_Aggregate - and then not Is_Fully_Constrained_Type (Get_Type (Expr)) - then - return Execute_Aggregate (Block, Expr, Expr_Type); - else - Res := Execute_Expression (Block, Expr); - Implicit_Array_Conversion (Block, Res, Expr_Type, Expr); - Check_Constraints (Block, Res, Expr_Type, Expr); - return Res; - end if; - end Execute_Expression_With_Type; - - function Execute_Signal_Init_Value (Block : Block_Instance_Acc; Expr : Iir) - return Iir_Value_Literal_Acc - is - Base : constant Iir := Get_Object_Prefix (Expr, False); - Info : constant Sim_Info_Acc := Get_Info (Base); - Bblk : Block_Instance_Acc; - Base_Val : Iir_Value_Literal_Acc; - Res : Iir_Value_Literal_Acc; - Is_Sig : Boolean; - begin - if Get_Kind (Base) = Iir_Kind_Object_Alias_Declaration then - Bblk := Get_Instance_By_Scope (Block, Info.Obj_Scope); - Base_Val := Execute_Signal_Init_Value (Bblk, Get_Name (Base)); - else - Bblk := Get_Instance_By_Scope (Block, Info.Obj_Scope); - Base_Val := Bblk.Objects (Info.Slot + 1); - end if; - Execute_Name_With_Base (Block, Expr, Base_Val, Res, Is_Sig); - pragma Assert (Is_Sig); - return Res; - end Execute_Signal_Init_Value; - - -- Indexed element will be at Pfx.Val_Array.V (Pos + 1) - procedure Execute_Indexed_Name (Block: Block_Instance_Acc; - Expr: Iir; - Pfx : Iir_Value_Literal_Acc; - Pos : out Iir_Index32) - is - pragma Assert (Get_Kind (Expr) = Iir_Kind_Indexed_Name); - Index_List : constant Iir_Flist := Get_Index_List (Expr); - Nbr_Dimensions : constant Iir_Index32 := - Iir_Index32 (Get_Nbr_Elements (Index_List)); - Index: Iir; - Value: Iir_Value_Literal_Acc; - Off : Iir_Index32; - begin - for I in 1 .. Nbr_Dimensions loop - Index := Get_Nth_Element (Index_List, Natural (I - 1)); - Value := Execute_Expression (Block, Index); - Off := Get_Index_Offset (Value, Pfx.Bounds.D (I), Expr); - if I = 1 then - Pos := Off; - else - Pos := Pos * Pfx.Bounds.D (I).Length + Off; - end if; - end loop; - end Execute_Indexed_Name; - - -- Indexed element will be at Pfx.Val_Array.V (Pos) - procedure Execute_Slice_Name (Prefix_Array: Iir_Value_Literal_Acc; - Srange : Iir_Value_Literal_Acc; - Low : out Iir_Index32; - High : out Iir_Index32; - Loc : Iir) - is - Index_Order : Order; - -- Lower and upper bounds of the slice. - begin - pragma Assert (Prefix_Array /= null); - - -- LRM93 6.5 - -- It is an error if the direction of the discrete range is not - -- the same as that of the index range of the array denoted by - -- the prefix of the slice name. - if Srange.Dir /= Prefix_Array.Bounds.D (1).Dir then - Error_Msg_Exec ("slice direction mismatch", Loc); - end if; - - -- LRM93 6.5 - -- It is an error if either of the bounds of the - -- discrete range does not belong to the index range of the - -- prefixing array, unless the slice is a null slice. - Index_Order := Compare_Value (Srange.Left, Srange.Right); - if (Srange.Dir = Iir_To and Index_Order = Greater) - or (Srange.Dir = Iir_Downto and Index_Order = Less) - then - -- Null slice. - Low := 1; - High := 0; - else - Low := Get_Index_Offset - (Srange.Left, Prefix_Array.Bounds.D (1), Loc); - High := Get_Index_Offset - (Srange.Right, Prefix_Array.Bounds.D (1), Loc); - end if; - end Execute_Slice_Name; - - procedure Execute_Name_With_Base (Block: Block_Instance_Acc; - Expr: Iir; - Base : Iir_Value_Literal_Acc; - Res : out Iir_Value_Literal_Acc; - Is_Sig : out Boolean) - is - Slot_Block: Block_Instance_Acc; - begin - -- Default value - Is_Sig := False; - - case Get_Kind (Expr) is - when Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration - | Iir_Kind_Stable_Attribute - | Iir_Kind_Quiet_Attribute - | Iir_Kind_Delayed_Attribute - | Iir_Kind_Transaction_Attribute => - Is_Sig := True; - if Base /= null then - Res := Base; - else - Slot_Block := Get_Instance_For_Slot (Block, Expr); - Res := Slot_Block.Objects (Get_Info (Expr).Slot); - end if; - - when Iir_Kind_Object_Alias_Declaration => - -- FIXME: add a flag ? - Is_Sig := Is_Signal_Object (Expr); - if Base /= null then - Res := Base; - else - Slot_Block := Get_Instance_For_Slot (Block, Expr); - Res := Slot_Block.Objects (Get_Info (Expr).Slot); - end if; - - when Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Constant_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_Interface_File_Declaration - | Iir_Kind_File_Declaration - | Iir_Kind_Attribute_Value - | Iir_Kind_Iterator_Declaration - | Iir_Kind_Terminal_Declaration - | Iir_Kinds_Quantity_Declaration => - if Base /= null then - Res := Base; - else - declare - Info : constant Sim_Info_Acc := Get_Info (Expr); - begin - Slot_Block := Get_Instance_By_Scope (Block, Info.Obj_Scope); - Res := Slot_Block.Objects (Info.Slot); - end; - end if; - - when Iir_Kind_Indexed_Name => - declare - Pfx : Iir_Value_Literal_Acc; - Pos : Iir_Index32; - begin - Execute_Name_With_Base - (Block, Get_Prefix (Expr), Base, Pfx, Is_Sig); - Execute_Indexed_Name (Block, Expr, Pfx, Pos); - Res := Pfx.Val_Array.V (Pos + 1); - end; - - when Iir_Kind_Slice_Name => - declare - Prefix_Array: Iir_Value_Literal_Acc; - Srange : Iir_Value_Literal_Acc; - Low, High: Iir_Index32; - begin - Execute_Name_With_Base - (Block, Get_Prefix (Expr), Base, Prefix_Array, Is_Sig); - - Srange := Execute_Bounds (Block, Get_Suffix (Expr)); - Execute_Slice_Name (Prefix_Array, Srange, Low, High, Expr); - - Res := Create_Array_Value (High - Low + 1, 1); - Res.Bounds.D (1) := Srange; - for I in Low .. High loop - Res.Val_Array.V (1 + I - Low) := - Prefix_Array.Val_Array.V (1 + I); - end loop; - end; - - when Iir_Kind_Selected_Element => - declare - Prefix: Iir_Value_Literal_Acc; - Pos: Iir_Index32; - begin - Execute_Name_With_Base - (Block, Get_Prefix (Expr), Base, Prefix, Is_Sig); - Pos := Get_Element_Position (Get_Selected_Element (Expr)); - Res := Prefix.Val_Record.V (Pos + 1); - end; - - when Iir_Kind_Dereference - | Iir_Kind_Implicit_Dereference => - declare - Prefix: Iir_Value_Literal_Acc; - begin - Prefix := Execute_Name (Block, Get_Prefix (Expr)); - Res := Prefix.Val_Access; - if Res = null then - Error_Msg_Exec ("deferencing null access", Expr); - end if; - end; - - when Iir_Kinds_Denoting_Name - | Iir_Kind_Attribute_Name => - Execute_Name_With_Base - (Block, Get_Named_Entity (Expr), Base, Res, Is_Sig); - - when Iir_Kind_Function_Call => - -- A prefix can be an expression - if Base /= null then - raise Internal_Error; - end if; - Res := Execute_Expression (Block, Expr); - - when Iir_Kind_Aggregate => - Res := Execute_Name_Aggregate (Block, Expr, Get_Type (Expr)); - -- FIXME: is_sig ? - - when Iir_Kind_Image_Attribute => - Res := Execute_Image_Attribute (Block, Expr); - - when Iir_Kind_Path_Name_Attribute - | Iir_Kind_Instance_Name_Attribute => - Res := Execute_Path_Instance_Name_Attribute (Block, Expr); - - when others => - Error_Kind ("execute_name_with_base", Expr); - end case; - end Execute_Name_With_Base; - - function Execute_Name (Block: Block_Instance_Acc; - Expr: Iir; - Ref : Boolean := False) - return Iir_Value_Literal_Acc - is - Res: Iir_Value_Literal_Acc; - Is_Sig : Boolean; - begin - Execute_Name_With_Base (Block, Expr, null, Res, Is_Sig); - if not Is_Sig or else Ref then - return Res; - else - return Execute_Signal_Value (Res); - end if; - end Execute_Name; - - function Execute_Value_Attribute (Block: Block_Instance_Acc; - Str_Val : Iir_Value_Literal_Acc; - Expr: Iir) - return Iir_Value_Literal_Acc - is - use Grt_Interface; - use Name_Table; - pragma Unreferenced (Block); - - Expr_Type : constant Iir := Get_Type (Expr); - Res : Iir_Value_Literal_Acc; - - Str_Bnd : aliased Std_String_Bound := Build_Bound (Str_Val); - Str_Str : aliased Std_String_Uncons (1 .. Str_Bnd.Dim_1.Length); - Str : aliased Std_String := (To_Std_String_Basep (Str_Str'Address), - To_Std_String_Boundp (Str_Bnd'Address)); - begin - Set_Std_String_From_Iir_Value (Str, Str_Val); - case Get_Kind (Expr_Type) is - when Iir_Kind_Integer_Type_Definition - | Iir_Kind_Integer_Subtype_Definition => - Res := Create_I64_Value - (Grt.Values.Ghdl_Value_I64 (Str'Unrestricted_Access)); - when Iir_Kind_Floating_Type_Definition - | Iir_Kind_Floating_Subtype_Definition => - Res := Create_F64_Value - (Grt.Values.Ghdl_Value_F64 (Str'Unrestricted_Access)); - when Iir_Kind_Physical_Type_Definition - | Iir_Kind_Physical_Subtype_Definition => - declare - Is_Real : Boolean; - Lit_Pos : Ghdl_Index_Type; - Lit_End : Ghdl_Index_Type; - Unit_Pos : Ghdl_Index_Type; - Unit_Len : Ghdl_Index_Type; - Mult : Ghdl_I64; - Unit : Iir; - Unit_Id : Name_Id; - begin - Grt.Values.Ghdl_Value_Physical_Split - (Str'Unrestricted_Access, - Is_Real, Lit_Pos, Lit_End, Unit_Pos); - - -- Find unit. - Unit_Len := 0; - Unit_Pos := Unit_Pos + 1; -- From 0 based to 1 based - for I in Unit_Pos .. Str_Bnd.Dim_1.Length loop - exit when Grt.Strings.Is_Whitespace (Str_Str (I)); - Unit_Len := Unit_Len + 1; - Str_Str (I) := Grt.Strings.To_Lower (Str_Str (I)); - end loop; - - Unit := Get_Primary_Unit (Expr_Type); - while Unit /= Null_Iir loop - Unit_Id := Get_Identifier (Unit); - exit when Get_Name_Length (Unit_Id) = Natural (Unit_Len) - and then Image (Unit_Id) = - String (Str_Str (Unit_Pos .. Unit_Pos + Unit_Len - 1)); - Unit := Get_Chain (Unit); - end loop; - - if Unit = Null_Iir then - Error_Msg_Exec ("incorrect unit name", Expr); - end if; - Mult := Ghdl_I64 (Get_Value (Get_Physical_Unit (Unit))); - - Str_Bnd.Dim_1.Length := Lit_End; - if Is_Real then - Res := Create_I64_Value - (Ghdl_I64 - (Grt.Values.Ghdl_Value_F64 (Str'Unrestricted_Access) - * Ghdl_F64 (Mult))); - else - Res := Create_I64_Value - (Grt.Values.Ghdl_Value_I64 (Str'Unrestricted_Access) - * Mult); - end if; - end; - when Iir_Kind_Enumeration_Type_Definition - | Iir_Kind_Enumeration_Subtype_Definition => - declare - Enums : constant Iir_Flist := - Get_Enumeration_Literal_List (Get_Base_Type (Expr_Type)); - Lit_Start : Ghdl_Index_Type; - Lit_End : Ghdl_Index_Type; - Enum : Iir; - Lit_Id : Name_Id; - Enum_Id : Name_Id; - begin - -- Remove leading and trailing blanks - for I in Str_Str'Range loop - if not Grt.Strings.Is_Whitespace (Str_Str (I)) then - Lit_Start := I; - exit; - end if; - end loop; - for I in reverse Lit_Start .. Str_Str'Last loop - if not Grt.Strings.Is_Whitespace (Str_Str (I)) then - Lit_End := I; - exit; - end if; - end loop; - - if Str_Str (Lit_Start) = ''' - and then Str_Str (Lit_End) = ''' - and then Lit_End = Lit_Start + 2 - then - -- Enumeration literal. - Lit_Id := Get_Identifier (Str_Str (Lit_Start + 1)); - - for I in Natural loop - Enum := Get_Nth_Element (Enums, I); - exit when Enum = Null_Iir; - exit when Get_Identifier (Enum) = Lit_Id; - end loop; - else - -- Literal identifier. - -- Convert to lower case. - for I in Lit_Start .. Lit_End loop - Str_Str (I) := Grt.Strings.To_Lower (Str_Str (I)); - end loop; - - for I in Natural loop - Enum := Get_Nth_Element (Enums, I); - exit when Enum = Null_Iir; - Enum_Id := Get_Identifier (Enum); - exit when (Get_Name_Length (Enum_Id) = - Natural (Lit_End - Lit_Start + 1)) - and then (Image (Enum_Id) = - String (Str_Str (Lit_Start .. Lit_End))); - end loop; - end if; - - if Enum = Null_Iir then - Error_Msg_Exec - ("incorrect enumeration literal for 'value", Expr); - end if; - - return Create_Enum_Value - (Natural (Get_Enum_Pos (Enum)), Expr_Type); - end; - when others => - Error_Kind ("value_attribute", Expr_Type); - end case; - return Res; - end Execute_Value_Attribute; - - -- For 'Last_Event and 'Last_Active: convert the absolute last time to - -- a relative delay. - function To_Relative_Time (T : Ghdl_I64) return Iir_Value_Literal_Acc is - A : Ghdl_I64; - begin - if T = -Ghdl_I64'Last then - A := Ghdl_I64'Last; - else - A := Ghdl_I64 (Grt.Types.Current_Time) - T; - end if; - return Create_I64_Value (A); - end To_Relative_Time; - - -- Evaluate an expression. - function Execute_Expression (Block: Block_Instance_Acc; Expr: Iir) - return Iir_Value_Literal_Acc - is - Res: Iir_Value_Literal_Acc; - begin - case Get_Kind (Expr) is - when Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Signal_Declaration - | Iir_Kind_Guard_Signal_Declaration - | Iir_Kind_Stable_Attribute - | Iir_Kind_Quiet_Attribute - | Iir_Kind_Delayed_Attribute - | Iir_Kind_Transaction_Attribute - | Iir_Kind_Object_Alias_Declaration => - Res := Execute_Name (Block, Expr); - return Res; - - when Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Constant_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Variable_Declaration - | Iir_Kind_Interface_File_Declaration - | Iir_Kind_File_Declaration - | Iir_Kind_Attribute_Value - | Iir_Kind_Iterator_Declaration - | Iir_Kind_Indexed_Name - | Iir_Kind_Slice_Name - | Iir_Kind_Selected_Element - | Iir_Kind_Dereference - | Iir_Kind_Implicit_Dereference => - return Execute_Name (Block, Expr); - - when Iir_Kinds_Denoting_Name - | Iir_Kind_Attribute_Name => - return Execute_Expression (Block, Get_Named_Entity (Expr)); - - when Iir_Kind_Aggregate => - return Execute_Aggregate (Block, Expr, Get_Type (Expr)); - when Iir_Kind_Simple_Aggregate => - return Execute_Simple_Aggregate (Block, Expr); - - when Iir_Kinds_Dyadic_Operator - | Iir_Kinds_Monadic_Operator => - declare - Imp : constant Iir := Get_Implementation (Expr); - begin - if Get_Implicit_Definition (Imp) in Iir_Predefined_Explicit then - return Execute_Function_Call (Block, Expr, Imp); - else - if Get_Kind (Expr) in Iir_Kinds_Dyadic_Operator then - Res := Execute_Implicit_Function - (Block, Expr, Get_Left (Expr), Get_Right (Expr), - Get_Type (Expr)); - else - Res := Execute_Implicit_Function - (Block, Expr, Get_Operand (Expr), Null_Iir, - Get_Type (Expr)); - end if; - return Res; - end if; - end; - - when Iir_Kind_Function_Call => - declare - Imp : constant Iir := Get_Implementation (Expr); - Assoc : Iir; - Args : Iir_Array (0 .. 1); - begin - if Get_Implicit_Definition (Imp) in Iir_Predefined_Explicit then - return Execute_Function_Call (Block, Expr, Imp); - else - Assoc := Get_Parameter_Association_Chain (Expr); - if Assoc /= Null_Iir then - Args (0) := Get_Actual (Assoc); - Assoc := Get_Chain (Assoc); - else - Args (0) := Null_Iir; - end if; - if Assoc /= Null_Iir then - Args (1) := Get_Actual (Assoc); - else - Args (1) := Null_Iir; - end if; - return Execute_Implicit_Function - (Block, Expr, Args (0), Args (1), Get_Type (Expr)); - end if; - end; - - when Iir_Kind_Integer_Literal => - declare - Lit_Type : constant Iir := Get_Base_Type (Get_Type (Expr)); - Lit : constant Iir_Int64 := Get_Value (Expr); - begin - case Get_Info (Lit_Type).Scalar_Mode is - when Iir_Value_I64 => - return Create_I64_Value (Ghdl_I64 (Lit)); - when others => - raise Internal_Error; - end case; - end; - - when Iir_Kind_Floating_Point_Literal => - return Create_F64_Value (Ghdl_F64 (Get_Fp_Value (Expr))); - - when Iir_Kind_Enumeration_Literal => - declare - Lit_Type : constant Iir := Get_Base_Type (Get_Type (Expr)); - Lit : constant Iir_Int32 := Get_Enum_Pos (Expr); - begin - case Get_Info (Lit_Type).Scalar_Mode is - when Iir_Value_B1 => - return Create_B1_Value (Ghdl_B1'Val (Lit)); - when Iir_Value_E8 => - return Create_E8_Value (Ghdl_E8'Val (Lit)); - when Iir_Value_E32 => - return Create_E32_Value (Ghdl_E32 (Lit)); - when others => - raise Internal_Error; - end case; - end; - - when Iir_Kind_Physical_Int_Literal - | Iir_Kind_Physical_Fp_Literal - | Iir_Kind_Unit_Declaration => - return Create_I64_Value - (Ghdl_I64 (Evaluation.Get_Physical_Value (Expr))); - - when Iir_Kind_String_Literal8 => - return String_To_Enumeration_Array (Block, Expr); - - when Iir_Kind_Null_Literal => - return Null_Lit; - - when Iir_Kind_Overflow_Literal => - Error_Msg_Constraint (Expr); - return null; - - when Iir_Kind_Parenthesis_Expression => - return Execute_Expression (Block, Get_Expression (Expr)); - - when Iir_Kind_Type_Conversion => - return Execute_Type_Conversion - (Block, Execute_Expression (Block, Get_Expression (Expr)), - Get_Type (Expr), Expr); - - when Iir_Kind_Qualified_Expression => - Res := Execute_Expression_With_Type - (Block, Get_Expression (Expr), Get_Type (Get_Type_Mark (Expr))); - return Res; - - when Iir_Kind_Allocator_By_Expression => - Res := Execute_Expression (Block, Get_Expression (Expr)); - Res := Unshare_Heap (Res); - return Create_Access_Value (Res); - - when Iir_Kind_Allocator_By_Subtype => - Res := Create_Value_For_Type - (Block, - Get_Type_Of_Subtype_Indication (Get_Subtype_Indication (Expr)), - Init_Value_Default); - Res := Unshare_Heap (Res); - return Create_Access_Value (Res); - - when Iir_Kind_Left_Type_Attribute => - Res := Execute_Bounds (Block, Get_Prefix (Expr)); - return Execute_Left_Limit (Res); - - when Iir_Kind_Right_Type_Attribute => - Res := Execute_Bounds (Block, Get_Prefix (Expr)); - return Execute_Right_Limit (Res); - - when Iir_Kind_High_Type_Attribute => - Res := Execute_Bounds (Block, Get_Prefix (Expr)); - return Execute_High_Limit (Res); - - when Iir_Kind_Low_Type_Attribute => - Res := Execute_Bounds (Block, Get_Prefix (Expr)); - return Execute_Low_Limit (Res); - - when Iir_Kind_High_Array_Attribute => - Res := Execute_Indexes (Block, Expr); - return Execute_High_Limit (Res); - - when Iir_Kind_Low_Array_Attribute => - Res := Execute_Indexes (Block, Expr); - return Execute_Low_Limit (Res); - - when Iir_Kind_Left_Array_Attribute => - Res := Execute_Indexes (Block, Expr); - return Execute_Left_Limit (Res); - - when Iir_Kind_Right_Array_Attribute => - Res := Execute_Indexes (Block, Expr); - return Execute_Right_Limit (Res); - - when Iir_Kind_Length_Array_Attribute => - Res := Execute_Indexes (Block, Expr); - return Execute_Length (Res); - - when Iir_Kind_Ascending_Array_Attribute => - Res := Execute_Indexes (Block, Expr); - return Boolean_To_Lit (Res.Dir = Iir_To); - - when Iir_Kind_Event_Attribute => - Res := Execute_Name (Block, Get_Prefix (Expr), True); - return Boolean_To_Lit (Execute_Event_Attribute (Res)); - - when Iir_Kind_Active_Attribute => - Res := Execute_Name (Block, Get_Prefix (Expr), True); - return Boolean_To_Lit (Execute_Active_Attribute (Res)); - - when Iir_Kind_Driving_Attribute => - Res := Execute_Name (Block, Get_Prefix (Expr), True); - return Boolean_To_Lit (Execute_Driving_Attribute (Res)); - - when Iir_Kind_Last_Value_Attribute => - Res := Execute_Name (Block, Get_Prefix (Expr), True); - return Execute_Last_Value_Attribute (Res); - - when Iir_Kind_Driving_Value_Attribute => - Res := Execute_Name (Block, Get_Prefix (Expr), True); - return Execute_Driving_Value_Attribute (Res); - - when Iir_Kind_Last_Event_Attribute => - Res := Execute_Name (Block, Get_Prefix (Expr), True); - return To_Relative_Time (Execute_Last_Event_Attribute (Res)); - - when Iir_Kind_Last_Active_Attribute => - Res := Execute_Name (Block, Get_Prefix (Expr), True); - return To_Relative_Time (Execute_Last_Active_Attribute (Res)); - - when Iir_Kind_Val_Attribute => - declare - Prefix_Type: constant Iir := Get_Type (Get_Prefix (Expr)); - Base_Type : constant Iir := Get_Base_Type (Prefix_Type); - Mode : constant Iir_Value_Kind := - Get_Info (Base_Type).Scalar_Mode; - begin - Res := Execute_Expression (Block, Get_Parameter (Expr)); - case Iir_Value_Discrete (Mode) is - when Iir_Value_I64 => - null; - when Iir_Value_E8 => - Res := Create_E8_Value (Ghdl_E8 (Res.I64)); - when Iir_Value_E32 => - Res := Create_E32_Value (Ghdl_E32 (Res.I64)); - when Iir_Value_B1 => - Res := Create_B1_Value (Ghdl_B1'Val (Res.I64)); - end case; - Check_Constraints (Block, Res, Prefix_Type, Expr); - return Res; - end; - - when Iir_Kind_Pos_Attribute => - declare - N_Res: Iir_Value_Literal_Acc; - Prefix_Type: constant Iir := Get_Type (Get_Prefix (Expr)); - Base_Type : constant Iir := Get_Base_Type (Prefix_Type); - Mode : constant Iir_Value_Kind := - Get_Info (Base_Type).Scalar_Mode; - begin - Res := Execute_Expression (Block, Get_Parameter (Expr)); - case Iir_Value_Discrete (Mode) is - when Iir_Value_I64 => - null; - when Iir_Value_B1 => - N_Res := Create_I64_Value (Ghdl_B1'Pos (Res.B1)); - Res := N_Res; - when Iir_Value_E8 => - N_Res := Create_I64_Value (Ghdl_I64 (Res.E8)); - Res := N_Res; - when Iir_Value_E32 => - N_Res := Create_I64_Value (Ghdl_I64 (Res.E32)); - Res := N_Res; - end case; - Check_Constraints (Block, Res, Get_Type (Expr), Expr); - return Res; - end; - - when Iir_Kind_Succ_Attribute => - Res := Execute_Expression (Block, Get_Parameter (Expr)); - Res := Execute_Inc (Res, Expr); - Check_Constraints (Block, Res, Get_Type (Expr), Expr); - return Res; - - when Iir_Kind_Pred_Attribute => - Res := Execute_Expression (Block, Get_Parameter (Expr)); - Res := Execute_Dec (Res, Expr); - Check_Constraints (Block, Res, Get_Type (Expr), Expr); - return Res; - - when Iir_Kind_Leftof_Attribute => - declare - Bound : Iir_Value_Literal_Acc; - begin - Res := Execute_Expression (Block, Get_Parameter (Expr)); - Bound := Execute_Bounds - (Block, Get_Type (Get_Prefix (Expr))); - case Bound.Dir is - when Iir_To => - Res := Execute_Dec (Res, Expr); - when Iir_Downto => - Res := Execute_Inc (Res, Expr); - end case; - Check_Constraints (Block, Res, Get_Type (Expr), Expr); - return Res; - end; - - when Iir_Kind_Rightof_Attribute => - declare - Bound : Iir_Value_Literal_Acc; - begin - Res := Execute_Expression (Block, Get_Parameter (Expr)); - Bound := Execute_Bounds - (Block, Get_Type (Get_Prefix (Expr))); - case Bound.Dir is - when Iir_Downto => - Res := Execute_Dec (Res, Expr); - when Iir_To => - Res := Execute_Inc (Res, Expr); - end case; - Check_Constraints (Block, Res, Get_Type (Expr), Expr); - return Res; - end; - - when Iir_Kind_Image_Attribute => - return Execute_Image_Attribute (Block, Expr); - - when Iir_Kind_Value_Attribute => - Res := Execute_Expression (Block, Get_Parameter (Expr)); - return Execute_Value_Attribute (Block, Res, Expr); - - when Iir_Kind_Path_Name_Attribute - | Iir_Kind_Instance_Name_Attribute => - return Execute_Path_Instance_Name_Attribute (Block, Expr); - - when others => - Error_Kind ("execute_expression", Expr); - end case; - end Execute_Expression; - - procedure Execute_Dyadic_Association - (Out_Block: Block_Instance_Acc; - In_Block: Block_Instance_Acc; - Expr : Iir; - Inter_Chain: Iir) - is - Inter: Iir; - Val: Iir_Value_Literal_Acc; - begin - Inter := Inter_Chain; - for I in 0 .. 1 loop - if I = 0 then - Val := Execute_Expression (Out_Block, Get_Left (Expr)); - else - Val := Execute_Expression (Out_Block, Get_Right (Expr)); - end if; - Implicit_Array_Conversion (In_Block, Val, Get_Type (Inter), Expr); - Check_Constraints (In_Block, Val, Get_Type (Inter), Expr); - - Elaboration.Create_Object (In_Block, Inter); - In_Block.Objects (Get_Info (Inter).Slot) := - Unshare (Val, Instance_Pool); - Inter := Get_Chain (Inter); - end loop; - end Execute_Dyadic_Association; - - procedure Execute_Monadic_Association - (Out_Block: Block_Instance_Acc; - In_Block: Block_Instance_Acc; - Expr : Iir; - Inter: Iir) - is - Val: Iir_Value_Literal_Acc; - begin - Val := Execute_Expression (Out_Block, Get_Operand (Expr)); - Implicit_Array_Conversion (In_Block, Val, Get_Type (Inter), Expr); - Check_Constraints (In_Block, Val, Get_Type (Inter), Expr); - - Elaboration.Create_Object (In_Block, Inter); - In_Block.Objects (Get_Info (Inter).Slot) := - Unshare (Val, Instance_Pool); - end Execute_Monadic_Association; - - -- Create a block instance for subprogram IMP. - function Create_Subprogram_Instance (Instance : Block_Instance_Acc; - Prot_Obj : Block_Instance_Acc; - Imp : Iir) - return Block_Instance_Acc - is - Func_Info : constant Sim_Info_Acc := Get_Info (Imp); - - subtype Block_Type is Block_Instance_Type (Func_Info.Nbr_Objects); - function To_Block_Instance_Acc is new - Ada.Unchecked_Conversion (System.Address, Block_Instance_Acc); - function Alloc_Block_Instance is new - Alloc_On_Pool_Addr (Block_Type); - - Up_Block: Block_Instance_Acc; - Up_Info : Sim_Info_Acc; - Res : Block_Instance_Acc; - - Origin : Iir; - Label : Iir; - begin - pragma Assert (Get_Kind (Imp) in Iir_Kinds_Subprogram_Declaration - or else Get_Kind (Imp) = Iir_Kind_Protected_Type_Body); - - if Prot_Obj /= null then - Up_Block := Prot_Obj; - Label := Imp; - else - Up_Info := Get_Info (Get_Parent (Imp)); - Up_Block := Get_Instance_By_Scope (Instance, Up_Info.Frame_Scope); - - Origin := Sem_Inst.Get_Origin (Imp); - if Origin /= Null_Iir then - -- Call to a subprogram of an instantiated package. - -- For a generic package, only the spec is instantiated, the body - -- is shared by all the instances. - - -- Execute code of the 'shared' body - Label := Origin; - - -- Get the real instance for package interface. - if Up_Info.Kind = Kind_Environment then - Up_Block := Environment_Table.Table - (Up_Block.Objects (Up_Info.Env_Slot).Environment); - end if; - else - Label := Imp; - end if; - end if; - - Res := To_Block_Instance_Acc - (Alloc_Block_Instance - (Instance_Pool, - Block_Instance_Type'(Max_Objs => Func_Info.Nbr_Objects, - Id => No_Block_Instance_Id, - Block_Scope => Get_Info (Label).Frame_Scope, - Up_Block => Up_Block, - Label => Label, - Stmt => Null_Iir, - Parent => Instance, - Children => null, - Brother => null, - Ports_Map => Null_Iir, - Marker => Empty_Marker, - Objects => (others => null), - Elab_Objects => 0, - In_Wait_Flag => False, - Actuals_Ref => null, - Result => null))); - return Res; - end Create_Subprogram_Instance; - - -- Destroy a dynamic block_instance. - procedure Execute_Subprogram_Call_Final (Instance : Block_Instance_Acc) - is - Subprg_Body : constant Iir := Get_Subprogram_Body (Instance.Label); - begin - Finalize_Declarative_Part - (Instance, Get_Declaration_Chain (Subprg_Body)); - end Execute_Subprogram_Call_Final; - - function Execute_Function_Body (Instance : Block_Instance_Acc) - return Iir_Value_Literal_Acc - is - Subprg_Body : constant Iir := Get_Subprogram_Body (Instance.Label); - Res : Iir_Value_Literal_Acc; - begin - Current_Process.Instance := Instance; - - Elaborate_Declarative_Part - (Instance, Get_Declaration_Chain (Subprg_Body)); - - -- execute statements - Instance.Stmt := Get_Sequential_Statement_Chain (Subprg_Body); - Execute_Sequential_Statements (Current_Process); - pragma Assert (Current_Process.Instance = Instance); - - if Instance.Result = null then - Error_Msg_Exec - ("function scope exited without a return statement", - Instance.Label); - end if; - - -- Free variables, slots... - -- Need to copy the return value, because it can contains values from - -- arguments. - Res := Instance.Result; - - Current_Process.Instance := Instance.Parent; - Execute_Subprogram_Call_Final (Instance); - - return Res; - end Execute_Function_Body; - - function Execute_Assoc_Function_Conversion - (Block : Block_Instance_Acc; Func : Iir; Val : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc - is - Inter : Iir; - Instance : Block_Instance_Acc; - Res : Iir_Value_Literal_Acc; - Marker : Mark_Type; - begin - Mark (Marker, Instance_Pool.all); - - -- Create an instance for this function. - Instance := Create_Subprogram_Instance (Block, null, Func); - - Inter := Get_Interface_Declaration_Chain (Func); - Elaboration.Create_Object (Instance, Inter); - -- FIXME: implicit conversion - Instance.Objects (Get_Info (Inter).Slot) := Val; - - Res := Execute_Function_Body (Instance); - Res := Unshare (Res, Expr_Pool'Access); - Release (Marker, Instance_Pool.all); - return Res; - end Execute_Assoc_Function_Conversion; - - function Execute_Assoc_Conversion - (Block : Block_Instance_Acc; Conv : Iir; Val : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc - is - Ent : Iir; - begin - case Get_Kind (Conv) is - when Iir_Kind_Function_Call => - -- FIXME: shouldn't CONV always be a denoting_name ? - return Execute_Assoc_Function_Conversion - (Block, Get_Implementation (Conv), Val); - when Iir_Kind_Type_Conversion => - -- FIXME: shouldn't CONV always be a denoting_name ? - return Execute_Type_Conversion (Block, Val, Get_Type (Conv), Conv); - when Iir_Kinds_Denoting_Name - | Iir_Kind_Function_Declaration => - Ent := Strip_Denoting_Name (Conv); - if Get_Kind (Ent) = Iir_Kind_Function_Declaration then - return Execute_Assoc_Function_Conversion (Block, Ent, Val); - elsif Get_Kind (Ent) in Iir_Kinds_Type_Declaration then - return Execute_Type_Conversion - (Block, Val, Get_Type (Ent), Ent); - else - Error_Kind ("execute_assoc_conversion(1)", Ent); - end if; - when others => - Error_Kind ("execute_assoc_conversion(2)", Conv); - end case; - end Execute_Assoc_Conversion; - - procedure Associate_By_Reference (Block : Block_Instance_Acc; - Formal : Iir; - Formal_Base : Iir_Value_Literal_Acc; - Actual : Iir_Value_Literal_Acc) - is - Prefix : constant Iir := Strip_Denoting_Name (Get_Prefix (Formal)); - Is_Sig : Boolean; - Pfx : Iir_Value_Literal_Acc; - Pos : Iir_Index32; - begin - if Get_Kind (Prefix) = Iir_Kind_Slice_Name then - -- That case is not handled correctly. - raise Program_Error; - end if; - Execute_Name_With_Base (Block, Prefix, Formal_Base, Pfx, Is_Sig); - - case Get_Kind (Formal) is - when Iir_Kind_Indexed_Name => - Execute_Indexed_Name (Block, Formal, Pfx, Pos); - Store (Pfx.Val_Array.V (Pos + 1), Actual); - when Iir_Kind_Slice_Name => - declare - Low, High : Iir_Index32; - Srange : Iir_Value_Literal_Acc; - begin - Srange := Execute_Bounds (Block, Get_Suffix (Formal)); - Execute_Slice_Name (Pfx, Srange, Low, High, Formal); - for I in 1 .. High - Low + 1 loop - Store (Pfx.Val_Array.V (Low + I), Actual.Val_Array.V (I)); - end loop; - end; - when Iir_Kind_Selected_Element => - Pos := Get_Element_Position (Get_Selected_Element (Formal)); - Store (Pfx.Val_Record.V (Pos + 1), Actual); - when others => - Error_Kind ("associate_by_reference", Formal); - end case; - end Associate_By_Reference; - - -- Establish correspondance for association list ASSOC_LIST from block - -- instance OUT_BLOCK for subprogram of block SUBPRG_BLOCK. - procedure Execute_Association - (Out_Block : Block_Instance_Acc; - Subprg_Block : Block_Instance_Acc; - Inter_Chain : Iir; - Assoc_Chain : Iir) - is - Nbr_Assoc : constant Natural := Get_Chain_Length (Assoc_Chain); - Assoc: Iir; - Assoc_Inter : Iir; - Actual : Iir; - Inter: Iir; - Formal : Iir; - Conv : Iir; - Val: Iir_Value_Literal_Acc; - Assoc_Idx : Iir_Index32; - Last_Individual : Iir_Value_Literal_Acc; - Mode : Iir_Mode; - Marker : Mark_Type; - begin - Subprg_Block.Actuals_Ref := null; - Mark (Marker, Expr_Pool); - - Assoc := Assoc_Chain; - Assoc_Inter := Inter_Chain; - Assoc_Idx := 1; - while Assoc /= Null_Iir loop - Inter := Get_Association_Interface (Assoc, Assoc_Inter); - Formal := Get_Association_Formal (Assoc, Inter); - - -- Extract the actual value. - case Get_Kind (Assoc) is - when Iir_Kind_Association_Element_Open => - -- Not allowed in individual association. - pragma Assert (Formal = Inter); - pragma Assert (Get_Whole_Association_Flag (Assoc)); - Actual := Get_Default_Value (Inter); - when Iir_Kind_Association_Element_By_Expression => - Actual := Get_Actual (Assoc); - when Iir_Kind_Association_Element_By_Individual => - -- Directly create the whole value on the instance pool, as its - -- life is longer than the statement. - if Get_Kind (Inter) = Iir_Kind_Interface_Signal_Declaration then - Last_Individual := Create_Value_For_Type - (Out_Block, Get_Actual_Type (Assoc), Init_Value_Signal); - else - Last_Individual := Create_Value_For_Type - (Out_Block, Get_Actual_Type (Assoc), Init_Value_Any); - end if; - Last_Individual := - Unshare (Last_Individual, Instance_Pool); - Elaboration.Create_Object (Subprg_Block, Inter); - Subprg_Block.Objects (Get_Info (Inter).Slot) := Last_Individual; - goto Continue; - when others => - Error_Kind ("execute_association(1)", Assoc); - end case; - - -- Compute actual value. - case Get_Kind (Inter) is - when Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_File_Declaration => - Val := Execute_Expression (Out_Block, Actual); - Implicit_Array_Conversion - (Subprg_Block, Val, Get_Type (Formal), Assoc); - Check_Constraints (Subprg_Block, Val, Get_Type (Formal), Assoc); - when Iir_Kind_Interface_Signal_Declaration => - Val := Execute_Name (Out_Block, Actual, True); - Implicit_Array_Conversion - (Subprg_Block, Val, Get_Type (Formal), Assoc); - when Iir_Kind_Interface_Variable_Declaration => - Mode := Get_Mode (Inter); - if Mode = Iir_In_Mode then - -- FIXME: Ref ? - Val := Execute_Expression (Out_Block, Actual); - else - Val := Execute_Name (Out_Block, Actual, False); - end if; - - -- FIXME: by value for scalars ? - - -- Keep ref for back-copy - if Mode /= Iir_In_Mode then - if Subprg_Block.Actuals_Ref = null then - declare - subtype Actuals_Ref_Type is - Value_Array (Iir_Index32 (Nbr_Assoc)); - function To_Value_Array_Acc is new - Ada.Unchecked_Conversion (System.Address, - Value_Array_Acc); - function Alloc_Actuals_Ref is new - Alloc_On_Pool_Addr (Actuals_Ref_Type); - - begin - Subprg_Block.Actuals_Ref := To_Value_Array_Acc - (Alloc_Actuals_Ref - (Instance_Pool, - Actuals_Ref_Type'(Len => Iir_Index32 (Nbr_Assoc), - V => (others => null)))); - end; - end if; - Subprg_Block.Actuals_Ref.V (Assoc_Idx) := - Unshare_Bounds (Val, Instance_Pool); - end if; - - if Mode = Iir_Out_Mode then - if Get_Formal_Conversion (Assoc) /= Null_Iir then - -- For an OUT variable using an out conversion, don't - -- associate with the actual, create a temporary value. - Val := Create_Value_For_Type - (Out_Block, Get_Type (Formal), Init_Value_Default); - elsif Get_Kind (Get_Type (Formal)) in - Iir_Kinds_Scalar_Type_And_Subtype_Definition - then - -- These are passed by value. Must be reset. - Val := Create_Value_For_Type - (Out_Block, Get_Type (Formal), Init_Value_Default); - end if; - else - if Get_Kind (Assoc) = - Iir_Kind_Association_Element_By_Expression - then - Conv := Get_Actual_Conversion (Assoc); - if Conv /= Null_Iir then - Val := Execute_Assoc_Conversion - (Subprg_Block, Conv, Val); - end if; - end if; - - -- FIXME: check constraints ? - end if; - - Implicit_Array_Conversion - (Subprg_Block, Val, Get_Type (Formal), Assoc); - - when others => - Error_Kind ("execute_association(2)", Inter); - end case; - - if Get_Whole_Association_Flag (Assoc) then - case Get_Kind (Inter) is - when Iir_Kind_Interface_Constant_Declaration - | Iir_Kind_Interface_Variable_Declaration - | Iir_Kind_Interface_File_Declaration => - -- FIXME: Arguments are passed by copy. - Elaboration.Create_Object (Subprg_Block, Inter); - Subprg_Block.Objects (Get_Info (Inter).Slot) := - Unshare (Val, Instance_Pool); - when Iir_Kind_Interface_Signal_Declaration => - Elaboration.Create_Signal (Subprg_Block, Inter); - Subprg_Block.Objects (Get_Info (Inter).Slot) := - Unshare_Bounds (Val, Instance_Pool); - when others => - Error_Kind ("execute_association", Inter); - end case; - else - Associate_By_Reference - (Subprg_Block, Formal, Last_Individual, Val); - end if; - - << Continue >> null; - Next_Association_Interface (Assoc, Assoc_Inter); - Assoc_Idx := Assoc_Idx + 1; - end loop; - - Release (Marker, Expr_Pool); - end Execute_Association; - - procedure Execute_Back_Association (Instance : Block_Instance_Acc) - is - Call : constant Iir := Get_Procedure_Call (Instance.Parent.Stmt); - Imp : constant Iir := Get_Implementation (Call); - Assoc : Iir; - Assoc_Inter : Iir; - Inter : Iir; - Formal : Iir; - Assoc_Idx : Iir_Index32; - begin - Assoc := Get_Parameter_Association_Chain (Call); - Assoc_Inter := Get_Interface_Declaration_Chain (Imp); - Assoc_Idx := 1; - while Assoc /= Null_Iir loop - if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Individual then - Inter := Get_Association_Interface (Assoc, Assoc_Inter); - Formal := Get_Association_Formal (Assoc, Inter); - - case Get_Kind (Inter) is - when Iir_Kind_Interface_Variable_Declaration => - if Get_Mode (Inter) /= Iir_In_Mode - and then Get_Kind (Get_Type (Inter)) /= - Iir_Kind_File_Type_Definition - then - -- For out/inout variable interface, the value must - -- be copied (FIXME: unless when passed by reference ?). - declare - Targ : constant Iir_Value_Literal_Acc := - Instance.Actuals_Ref.V (Assoc_Idx); - Base : constant Iir_Value_Literal_Acc := - Instance.Objects (Get_Info (Inter).Slot); - Val : Iir_Value_Literal_Acc; - Conv : Iir; - Is_Sig : Boolean; - Expr_Mark : Mark_Type; - begin - Mark (Expr_Mark, Expr_Pool); - - -- Extract for individual association. - Execute_Name_With_Base - (Instance, Formal, Base, Val, Is_Sig); - Conv := Get_Formal_Conversion (Assoc); - if Conv /= Null_Iir then - Val := Execute_Assoc_Conversion - (Instance, Conv, Val); - -- FIXME: free val ? - end if; - Store (Targ, Val); - - Release (Expr_Mark, Expr_Pool); - end; - end if; - when Iir_Kind_Interface_File_Declaration => - null; - when Iir_Kind_Interface_Signal_Declaration - | Iir_Kind_Interface_Constant_Declaration => - null; - when others => - Error_Kind ("execute_back_association", Inter); - end case; - end if; - Next_Association_Interface (Assoc, Assoc_Inter); - Assoc_Idx := Assoc_Idx + 1; - end loop; - end Execute_Back_Association; - - function Get_Protected_Object_Instance - (Block : Block_Instance_Acc; Call : Iir) return Block_Instance_Acc - is - Meth_Obj : constant Iir := Get_Method_Object (Call); - Obj : Iir_Value_Literal_Acc; - begin - if Meth_Obj = Null_Iir then - return null; - else - Obj := Execute_Name (Block, Meth_Obj, True); - return Protected_Table.Table (Obj.Prot); - end if; - end Get_Protected_Object_Instance; - - function Execute_Foreign_Function_Call - (Block: Block_Instance_Acc; Expr : Iir; Imp : Iir) - return Iir_Value_Literal_Acc - is - Res : Iir_Value_Literal_Acc; - begin - case Get_Identifier (Imp) is - when Std_Names.Name_Get_Resolution_Limit => - Res := Create_I64_Value - (Ghdl_I64 - (Evaluation.Get_Physical_Value (Std_Package.Time_Base))); - when Std_Names.Name_Textio_Read_Real => - Res := Create_F64_Value - (File_Operation.Textio_Read_Real (Block.Objects (1))); - when others => - Error_Msg_Exec ("unsupported foreign function call", Expr); - end case; - return Res; - end Execute_Foreign_Function_Call; - - -- BLOCK is the block instance in which the function call appears. - function Execute_Function_Call - (Block: Block_Instance_Acc; Expr: Iir; Imp : Iir) - return Iir_Value_Literal_Acc - is - Inter_Chain : constant Iir := Get_Interface_Declaration_Chain (Imp); - Subprg_Block: Block_Instance_Acc; - Prot_Block : Block_Instance_Acc; - Assoc_Chain: Iir; - Res : Iir_Value_Literal_Acc; - begin - Mark (Block.Marker, Instance_Pool.all); - - case Get_Kind (Expr) is - when Iir_Kind_Function_Call => - Prot_Block := Get_Protected_Object_Instance (Block, Expr); - Subprg_Block := - Create_Subprogram_Instance (Block, Prot_Block, Imp); - Assoc_Chain := Get_Parameter_Association_Chain (Expr); - Execute_Association - (Block, Subprg_Block, Inter_Chain, Assoc_Chain); - -- No out/inout interface for functions. - pragma Assert (Subprg_Block.Actuals_Ref = null); - when Iir_Kinds_Dyadic_Operator => - Subprg_Block := Create_Subprogram_Instance (Block, null, Imp); - Execute_Dyadic_Association - (Block, Subprg_Block, Expr, Inter_Chain); - when Iir_Kinds_Monadic_Operator => - Subprg_Block := Create_Subprogram_Instance (Block, null, Imp); - Execute_Monadic_Association - (Block, Subprg_Block, Expr, Inter_Chain); - when others => - Error_Kind ("execute_subprogram_call_init", Expr); - end case; - - if Get_Foreign_Flag (Imp) then - Res := Execute_Foreign_Function_Call (Subprg_Block, Expr, Imp); - else - Res := Execute_Function_Body (Subprg_Block); - end if; - - -- Unfortunately, we don't know where the result has been allocated, - -- so copy it before releasing the instance pool. - Res := Unshare (Res, Expr_Pool'Access); - - Release (Block.Marker, Instance_Pool.all); - - return Res; - end Execute_Function_Call; - - -- Slide an array VALUE using bounds from REF_VALUE. Do not modify - -- VALUE if not an array. - procedure Implicit_Array_Conversion (Value : in out Iir_Value_Literal_Acc; - Ref_Value : Iir_Value_Literal_Acc; - Expr : Iir) - is - Res : Iir_Value_Literal_Acc; - begin - if Value.Kind /= Iir_Value_Array then - return; - end if; - Res := Create_Array_Value (Value.Bounds.Nbr_Dims); - Res.Val_Array := Value.Val_Array; - for I in Value.Bounds.D'Range loop - if Value.Bounds.D (I).Length /= Ref_Value.Bounds.D (I).Length then - Error_Msg_Constraint (Expr); - return; - end if; - Res.Bounds.D (I) := Ref_Value.Bounds.D (I); - end loop; - Value := Res; - end Implicit_Array_Conversion; - - procedure Implicit_Array_Conversion (Instance : Block_Instance_Acc; - Value : in out Iir_Value_Literal_Acc; - Ref_Type : Iir; - Expr : Iir) - is - Ref_Value : Iir_Value_Literal_Acc; - begin - -- Do array conversion only if REF_TYPE is a constrained array type - -- definition. - if Value.Kind /= Iir_Value_Array then - return; - end if; - if Get_Constraint_State (Ref_Type) /= Fully_Constrained then - return; - end if; - Ref_Value := Create_Array_Bounds_From_Type (Instance, Ref_Type, True); - for I in Value.Bounds.D'Range loop - if Value.Bounds.D (I).Length /= Ref_Value.Bounds.D (I).Length then - Error_Msg_Constraint (Expr); - return; - end if; - end loop; - Ref_Value.Val_Array.V := Value.Val_Array.V; - Value := Ref_Value; - end Implicit_Array_Conversion; - - procedure Check_Array_Constraints - (Instance: Block_Instance_Acc; - Value: Iir_Value_Literal_Acc; - Def: Iir; - Expr: Iir) - is - Index_List : Iir_Flist; - Element_Subtype : Iir; - New_Bounds : Iir_Value_Literal_Acc; - begin - -- Nothing to check for unconstrained arrays. - if not Get_Index_Constraint_Flag (Def) then - return; - end if; - - Index_List := Get_Index_Subtype_List (Def); - for I in Value.Bounds.D'Range loop - New_Bounds := Execute_Bounds - (Instance, Get_Nth_Element (Index_List, Natural (I - 1))); - if not Is_Equal (Value.Bounds.D (I), New_Bounds) then - Error_Msg_Constraint (Expr); - return; - end if; - end loop; - - if Boolean'(False) then - Index_List := Get_Index_List (Def); - Element_Subtype := Get_Element_Subtype (Def); - for I in Value.Val_Array.V'Range loop - Check_Constraints - (Instance, Value.Val_Array.V (I), Element_Subtype, Expr); - end loop; - end if; - end Check_Array_Constraints; - - -- Check DEST and SRC are array compatible. - procedure Check_Array_Match - (Instance: Block_Instance_Acc; - Dest: Iir_Value_Literal_Acc; - Src : Iir_Value_Literal_Acc; - Expr: Iir) - is - pragma Unreferenced (Instance); - begin - for I in Dest.Bounds.D'Range loop - if Dest.Bounds.D (I).Length /= Src.Bounds.D (I).Length then - Error_Msg_Constraint (Expr); - exit; - end if; - end loop; - end Check_Array_Match; - pragma Unreferenced (Check_Array_Match); - - procedure Check_Constraints - (Instance: Block_Instance_Acc; - Value: Iir_Value_Literal_Acc; - Def: Iir; - Expr: Iir) - is - Base_Type : constant Iir := Get_Base_Type (Def); - High, Low: Iir_Value_Literal_Acc; - Bound : Iir_Value_Literal_Acc; - begin - case Get_Kind (Def) is - when Iir_Kind_Integer_Subtype_Definition - | Iir_Kind_Floating_Subtype_Definition - | Iir_Kind_Enumeration_Subtype_Definition - | Iir_Kind_Physical_Subtype_Definition - | Iir_Kind_Enumeration_Type_Definition => - Bound := Execute_Bounds (Instance, Def); - if Bound.Dir = Iir_To then - High := Bound.Right; - Low := Bound.Left; - else - High := Bound.Left; - Low := Bound.Right; - end if; - case Iir_Value_Scalars (Get_Info (Base_Type).Scalar_Mode) is - when Iir_Value_I64 => - if Value.I64 in Low.I64 .. High.I64 then - return; - end if; - when Iir_Value_E8 => - if Value.E8 in Low.E8 .. High.E8 then - return; - end if; - when Iir_Value_E32 => - if Value.E32 in Low.E32 .. High.E32 then - return; - end if; - when Iir_Value_F64 => - if Value.F64 in Low.F64 .. High.F64 then - return; - end if; - when Iir_Value_B1 => - if Value.B1 in Low.B1 .. High.B1 then - return; - end if; - end case; - when Iir_Kind_Array_Subtype_Definition - | Iir_Kind_Array_Type_Definition => - Check_Array_Constraints (Instance, Value, Def, Expr); - return; - when Iir_Kind_Record_Type_Definition - | Iir_Kind_Record_Subtype_Definition => - declare - List : constant Iir_Flist := - Get_Elements_Declaration_List (Get_Base_Type (Def)); - El : Iir_Element_Declaration; - begin - for I in Flist_First .. Flist_Last (List) loop - El := Get_Nth_Element (List, I); - Check_Constraints - (Instance, - Value.Val_Record.V (Get_Element_Position (El) + 1), - Get_Type (El), - Expr); - end loop; - end; - return; - when Iir_Kind_Integer_Type_Definition => - return; - when Iir_Kind_Floating_Type_Definition => - return; - when Iir_Kind_Physical_Type_Definition => - return; - when Iir_Kind_Access_Type_Definition - | Iir_Kind_Access_Subtype_Definition => - return; - when Iir_Kind_File_Type_Definition => - return; - when others => - Error_Kind ("check_constraints", Def); - end case; - Error_Msg_Constraint (Expr); - end Check_Constraints; - - function Execute_Resolution_Function - (Block: Block_Instance_Acc; Imp : Iir; Arr : Iir_Value_Literal_Acc) - return Iir_Value_Literal_Acc - is - Inter : Iir; - Instance : Block_Instance_Acc; - begin - -- Create a frame for this function. - Instance := Create_Subprogram_Instance (Block, null, Imp); - - Inter := Get_Interface_Declaration_Chain (Imp); - Elaboration.Create_Object (Instance, Inter); - Instance.Objects (Get_Info (Inter).Slot) := Arr; - - return Execute_Function_Body (Instance); - end Execute_Resolution_Function; - - procedure Execute_Signal_Assignment - (Instance: Block_Instance_Acc; - Stmt: Iir_Signal_Assignment_Statement) - is - Wf : constant Iir_Waveform_Element := Get_Waveform_Chain (Stmt); - Nbr_We : constant Natural := Get_Chain_Length (Wf); - - Transactions : Transaction_Type (Nbr_We); - - We: Iir_Waveform_Element; - Res: Iir_Value_Literal_Acc; - Rdest: Iir_Value_Literal_Acc; - Targ_Type : Iir; - Marker : Mark_Type; - begin - Mark (Marker, Expr_Pool); - - Rdest := Execute_Name (Instance, Get_Target (Stmt), True); - Targ_Type := Get_Type (Get_Target (Stmt)); - - -- Disconnection statement. - if Wf = Null_Iir then - Disconnect_Signal (Rdest); - Release (Marker, Expr_Pool); - return; - end if; - - Transactions.Stmt := Stmt; - - -- LRM93 8.4.1 - -- Evaluation of a waveform consists of the evaluation of each waveform - -- elements in the waveform. - We := Wf; - for I in Transactions.Els'Range loop - declare - Trans : Transaction_El_Type renames Transactions.Els (I); - begin - if Get_Time (We) /= Null_Iir then - Res := Execute_Expression (Instance, Get_Time (We)); - -- LRM93 8.4.1 - -- It is an error if the time expression in a waveform element - -- evaluates to a negative value. - if Res.I64 < 0 then - Error_Msg_Exec ("time value is negative", Get_Time (We)); - end if; - Trans.After := Std_Time (Res.I64); - else - -- LRM93 8.4.1 - -- If the after clause of a waveform element is not present, - -- then an implicit "after 0 ns" is assumed. - Trans.After := 0; - end if; - - -- LRM93 8.4.1 - -- It is an error if the sequence of new transactions is not in - -- ascending order with respect to time. - if I > 1 - and then Trans.After <= Transactions.Els (I - 1).After - then - Error_Msg_Exec - ("sequence not in ascending order with respect to time", We); - end if; - - if Get_Kind (Get_We_Value (We)) = Iir_Kind_Null_Literal then - -- null transaction. - Trans.Value := null; - else - -- LRM93 8.4.1 - -- For the first form of waveform element, the value component - -- of the transaction is determined by the value expression in - -- the waveform element. - Trans.Value := Execute_Expression_With_Type - (Instance, Get_We_Value (We), Targ_Type); - end if; - end; - We := Get_Chain (We); - end loop; - pragma Assert (We = Null_Iir); - - case Get_Delay_Mechanism (Stmt) is - when Iir_Transport_Delay => - Transactions.Reject := 0; - when Iir_Inertial_Delay => - -- LRM93 8.4 - -- or, in the case that a pulse rejection limit is specified, - -- a pulse whose duration is shorter than that limit will not - -- be transmitted. - -- Every inertially delayed signal assignment has a pulse - -- rejection limit. - if Get_Reject_Time_Expression (Stmt) /= Null_Iir then - -- LRM93 8.4 - -- If the delay mechanism specifies inertial delay, and if the - -- reserved word reject followed by a time expression is - -- present, then the time expression specifies the pulse - -- rejection limit. - Res := Execute_Expression - (Instance, Get_Reject_Time_Expression (Stmt)); - -- LRM93 8.4 - -- It is an error if the pulse rejection limit for any - -- inertially delayed signal assignement statement is either - -- negative ... - if Res.I64 < 0 then - Error_Msg_Exec ("reject time negative", Stmt); - end if; - -- LRM93 8.4 - -- ... or greather than the time expression associated with - -- the first waveform element. - Transactions.Reject := Std_Time (Res.I64); - if Transactions.Reject > Transactions.Els (1).After then - Error_Msg_Exec - ("reject time greather than time expression", Stmt); - end if; - else - -- LRM93 8.4 - -- In all other cases, the pulse rejection limit is the time - -- expression associated ith the first waveform element. - Transactions.Reject := Transactions.Els (1).After; - end if; - end case; - - -- FIXME: slice Transactions to remove transactions after end of time. - Assign_Value_To_Signal (Instance, Rdest, Transactions); - - Release (Marker, Expr_Pool); - end Execute_Signal_Assignment; - - -- Display a message when an assertion has failed. - -- REPORT is the value (string) to display, or null to use default message. - -- SEVERITY is the severity or null to use default (error). - -- STMT is used to display location. - procedure Execute_Failed_Assertion (Msg : String; - Report : String; - Severity : Natural; - Stmt: Iir) is - begin - -- LRM93 8.2 - -- The error message consists of at least: - - -- 4: name of the design unit containing the assertion. - Put (Standard_Error, Disp_Location (Stmt)); - - -- 1: an indication that this message is from an assertion. - Put (Standard_Error, '('); - Put (Standard_Error, Msg); - Put (Standard_Error, ' '); - - -- 2: the value of the severity level. - case Severity is - when 0 => - Put (Standard_Error, "note"); - when 1 => - Put (Standard_Error, "warning"); - when 2 => - Put (Standard_Error, "error"); - when 3 => - Put (Standard_Error, "failure"); - when others => - Error_Internal (Null_Iir, "execute_failed_assertion"); - end case; - if Disp_Time_Before_Values then - Put (Standard_Error, " at "); - Grt.Astdio.Put_Time (Grt.Stdio.stderr, Current_Time); - end if; - Put (Standard_Error, "): "); - - -- 3: the value of the message string. - Put_Line (Standard_Error, Report); - - -- Stop execution if the severity is too high. - if Severity >= Grt.Options.Severity_Level then - Debug (Reason_Assert); - Grt.Errors.Fatal_Error; - end if; - end Execute_Failed_Assertion; - - procedure Execute_Failed_Assertion - (Instance: Block_Instance_Acc; - Label : String; - Stmt : Iir; - Default_Msg : String; - Default_Severity : Natural) - is - Expr: Iir; - Report, Severity_Lit: Iir_Value_Literal_Acc; - Severity : Natural; - Marker : Mark_Type; - begin - Mark (Marker, Expr_Pool); - Expr := Get_Report_Expression (Stmt); - if Expr /= Null_Iir then - Report := Execute_Expression (Instance, Expr); - else - Report := null; - end if; - Expr := Get_Severity_Expression (Stmt); - if Expr /= Null_Iir then - Severity_Lit := Execute_Expression (Instance, Expr); - Severity := Natural'Val (Severity_Lit.E8); - else - Severity := Default_Severity; - end if; - if Report /= null then - declare - Msg : String (1 .. Natural (Report.Val_Array.Len)); - begin - for I in Report.Val_Array.V'Range loop - Msg (Positive (I)) := - Character'Val (Report.Val_Array.V (I).E8); - end loop; - Execute_Failed_Assertion (Label, Msg, Severity, Stmt); - end; - else - Execute_Failed_Assertion (Label, Default_Msg, Severity, Stmt); - end if; - Release (Marker, Expr_Pool); - end Execute_Failed_Assertion; - - function Is_In_Choice - (Instance: Block_Instance_Acc; - Choice: Iir; - Expr: Iir_Value_Literal_Acc) - return Boolean - is - Res : Boolean; - begin - case Get_Kind (Choice) is - when Iir_Kind_Choice_By_Others => - return True; - when Iir_Kind_Choice_By_Expression => - declare - Expr1: Iir_Value_Literal_Acc; - begin - Expr1 := Execute_Expression - (Instance, Get_Choice_Expression (Choice)); - Res := Is_Equal (Expr, Expr1); - return Res; - end; - when Iir_Kind_Choice_By_Range => - declare - A_Range : Iir_Value_Literal_Acc; - begin - A_Range := Execute_Bounds - (Instance, Get_Choice_Range (Choice)); - Res := Is_In_Range (Expr, A_Range); - end; - return Res; - when others => - Error_Kind ("is_in_choice", Choice); - end case; - end Is_In_Choice; - - -- Return TRUE iff VAL is in the range defined by BOUNDS. - function Is_In_Range (Val : Iir_Value_Literal_Acc; - Bounds : Iir_Value_Literal_Acc) - return Boolean - is - Max, Min : Iir_Value_Literal_Acc; - begin - case Bounds.Dir is - when Iir_To => - Min := Bounds.Left; - Max := Bounds.Right; - when Iir_Downto => - Min := Bounds.Right; - Max := Bounds.Left; - end case; - - case Iir_Value_Discrete (Val.Kind) is - when Iir_Value_E8 => - return Val.E8 >= Min.E8 and Val.E8 <= Max.E8; - when Iir_Value_E32 => - return Val.E32 >= Min.E32 and Val.E32 <= Max.E32; - when Iir_Value_B1 => - return Val.B1 >= Min.B1 and Val.B1 <= Max.B1; - when Iir_Value_I64 => - return Val.I64 >= Min.I64 and Val.I64 <= Max.I64; - end case; - end Is_In_Range; - - -- Increment or decrement VAL according to BOUNDS.DIR. - -- FIXME: use increment ? - procedure Update_Loop_Index (Val : Iir_Value_Literal_Acc; - Bounds : Iir_Value_Literal_Acc) - is - begin - case Iir_Value_Discrete (Val.Kind) is - when Iir_Value_E8 => - case Bounds.Dir is - when Iir_To => - Val.E8 := Val.E8 + 1; - when Iir_Downto => - Val.E8 := Val.E8 - 1; - end case; - when Iir_Value_E32 => - case Bounds.Dir is - when Iir_To => - Val.E32 := Val.E32 + 1; - when Iir_Downto => - Val.E32 := Val.E32 - 1; - end case; - when Iir_Value_B1 => - case Bounds.Dir is - when Iir_To => - Val.B1 := True; - when Iir_Downto => - Val.B1 := False; - end case; - when Iir_Value_I64 => - case Bounds.Dir is - when Iir_To => - Val.I64 := Val.I64 + 1; - when Iir_Downto => - Val.I64 := Val.I64 - 1; - end case; - end case; - end Update_Loop_Index; - - procedure Finalize_For_Loop_Statement (Instance : Block_Instance_Acc; - Stmt : Iir) - is - begin - Destroy_Iterator_Declaration - (Instance, Get_Parameter_Specification (Stmt)); - end Finalize_For_Loop_Statement; - - procedure Finalize_Loop_Statement (Instance : Block_Instance_Acc; - Stmt : Iir) - is - begin - if Get_Kind (Stmt) = Iir_Kind_For_Loop_Statement then - Finalize_For_Loop_Statement (Instance, Stmt); - end if; - end Finalize_Loop_Statement; - - procedure Execute_For_Loop_Statement (Proc : Process_State_Acc) - is - Instance : constant Block_Instance_Acc := Proc.Instance; - Stmt : constant Iir_For_Loop_Statement := Instance.Stmt; - Iterator : constant Iir := Get_Parameter_Specification (Stmt); - Bounds : Iir_Value_Literal_Acc; - Index : Iir_Value_Literal_Acc; - Stmt_Chain : Iir; - Is_Nul : Boolean; - Marker : Mark_Type; - begin - -- Elaborate the iterator (and its type). - Elaborate_Declaration (Instance, Iterator); - - -- Extract bounds. - Mark (Marker, Expr_Pool); - Bounds := Execute_Bounds (Instance, Get_Type (Iterator)); - Index := Instance.Objects (Get_Info (Iterator).Slot); - Store (Index, Bounds.Left); - Is_Nul := Is_Null_Range (Bounds); - Release (Marker, Expr_Pool); - - if Is_Nul then - -- Loop is complete. - Finalize_For_Loop_Statement (Instance, Stmt); - Update_Next_Statement (Proc); - else - Stmt_Chain := Get_Sequential_Statement_Chain (Stmt); - if Stmt_Chain = Null_Iir then - -- Nothing to do for an empty loop. - Finalize_For_Loop_Statement (Instance, Stmt); - Update_Next_Statement (Proc); - else - Instance.Stmt := Stmt_Chain; - end if; - end if; - end Execute_For_Loop_Statement; - - -- This function is called when there is no more statements to execute - -- in the statement list of a for_loop. Returns FALSE in case of end of - -- loop. - function Finish_For_Loop_Statement (Instance : Block_Instance_Acc) - return Boolean - is - Iterator : constant Iir := Get_Parameter_Specification (Instance.Stmt); - Bounds : Iir_Value_Literal_Acc; - Index : Iir_Value_Literal_Acc; - Marker : Mark_Type; - begin - -- FIXME: avoid allocation. - Mark (Marker, Expr_Pool); - Bounds := Execute_Bounds (Instance, Get_Type (Iterator)); - Index := Instance.Objects (Get_Info (Iterator).Slot); - - if Is_Equal (Index, Bounds.Right) then - -- Loop is complete. - Release (Marker, Expr_Pool); - Finalize_For_Loop_Statement (Instance, Instance.Stmt); - return False; - else - -- Update the loop index. - Update_Loop_Index (Index, Bounds); - - Release (Marker, Expr_Pool); - - -- start the loop again. - Instance.Stmt := Get_Sequential_Statement_Chain (Instance.Stmt); - return True; - end if; - end Finish_For_Loop_Statement; - - -- Evaluate boolean condition COND. If COND is Null_Iir, returns true. - function Execute_Condition (Instance : Block_Instance_Acc; - Cond : Iir) return Boolean - is - V : Iir_Value_Literal_Acc; - Res : Boolean; - Marker : Mark_Type; - begin - if Cond = Null_Iir then - return True; - end if; - - Mark (Marker, Expr_Pool); - V := Execute_Expression (Instance, Cond); - Res := V.B1 = True; - Release (Marker, Expr_Pool); - return Res; - end Execute_Condition; - - -- Start a while loop statement, or return FALSE if the loop is not - -- executed. - procedure Execute_While_Loop_Statement (Proc : Process_State_Acc) - is - Instance: constant Block_Instance_Acc := Proc.Instance; - Stmt : constant Iir := Instance.Stmt; - Cond : Boolean; - begin - Cond := Execute_Condition (Instance, Get_Condition (Stmt)); - if Cond then - Init_Sequential_Statements (Proc, Stmt); - else - Update_Next_Statement (Proc); - end if; - end Execute_While_Loop_Statement; - - -- This function is called when there is no more statements to execute - -- in the statement list of a while loop. Returns FALSE iff loop is - -- completed. - function Finish_While_Loop_Statement (Instance : Block_Instance_Acc) - return Boolean - is - Cond : Boolean; - begin - Cond := Execute_Condition (Instance, Get_Condition (Instance.Stmt)); - - if Cond then - -- start the loop again. - Instance.Stmt := Get_Sequential_Statement_Chain (Instance.Stmt); - return True; - else - -- Loop is complete. - return False; - end if; - end Finish_While_Loop_Statement; - - -- Return TRUE if the loop must be executed again - function Finish_Loop_Statement (Instance : Block_Instance_Acc; - Stmt : Iir) return Boolean is - begin - Instance.Stmt := Stmt; - case Get_Kind (Stmt) is - when Iir_Kind_While_Loop_Statement => - return Finish_While_Loop_Statement (Instance); - when Iir_Kind_For_Loop_Statement => - return Finish_For_Loop_Statement (Instance); - when others => - Error_Kind ("finish_loop_statement", Stmt); - end case; - end Finish_Loop_Statement; - - -- Return FALSE if the next statement should be executed (possibly - -- updated). - procedure Execute_Exit_Next_Statement (Proc : Process_State_Acc; - Is_Exit : Boolean) - is - Instance : constant Block_Instance_Acc := Proc.Instance; - Stmt : constant Iir := Instance.Stmt; - Label : constant Iir := Get_Named_Entity (Get_Loop_Label (Stmt)); - Cond : Boolean; - Parent : Iir; - begin - Cond := Execute_Condition (Instance, Get_Condition (Stmt)); - if not Cond then - Update_Next_Statement (Proc); - return; - end if; - - Parent := Stmt; - loop - Parent := Get_Parent (Parent); - case Get_Kind (Parent) is - when Iir_Kind_For_Loop_Statement - | Iir_Kind_While_Loop_Statement => - if Label = Null_Iir or else Label = Parent then - -- Target is this statement. - if Is_Exit then - Finalize_Loop_Statement (Instance, Parent); - Instance.Stmt := Parent; - Update_Next_Statement (Proc); - elsif not Finish_Loop_Statement (Instance, Parent) then - Update_Next_Statement (Proc); - else - Init_Sequential_Statements (Proc, Parent); - end if; - return; - else - Finalize_Loop_Statement (Instance, Parent); - end if; - when others => - null; - end case; - end loop; - end Execute_Exit_Next_Statement; - - procedure Execute_Case_Statement (Proc : Process_State_Acc) - is - Instance : constant Block_Instance_Acc := Proc.Instance; - Stmt : constant Iir := Instance.Stmt; - Value: Iir_Value_Literal_Acc; - Assoc: Iir; - Stmt_Chain : Iir; - Marker : Mark_Type; - begin - Mark (Marker, Expr_Pool); - - Value := Execute_Expression (Instance, Get_Expression (Stmt)); - Assoc := Get_Case_Statement_Alternative_Chain (Stmt); - - while Assoc /= Null_Iir loop - if not Get_Same_Alternative_Flag (Assoc) then - Stmt_Chain := Get_Associated_Chain (Assoc); - end if; - - if Is_In_Choice (Instance, Assoc, Value) then - if Stmt_Chain = Null_Iir then - Update_Next_Statement (Proc); - else - Instance.Stmt := Stmt_Chain; - end if; - Release (Marker, Expr_Pool); - return; - end if; - - Assoc := Get_Chain (Assoc); - end loop; - -- FIXME: infinite loop??? - Error_Msg_Exec ("no choice for expression", Stmt); - raise Internal_Error; - end Execute_Case_Statement; - - procedure Execute_Call_Statement (Proc : Process_State_Acc) - is - Instance : constant Block_Instance_Acc := Proc.Instance; - Stmt : constant Iir := Instance.Stmt; - Call : constant Iir := Get_Procedure_Call (Stmt); - Imp : constant Iir := Get_Implementation (Call); - Subprg_Instance : Block_Instance_Acc; - Prot_Block : Block_Instance_Acc; - Assoc_Chain: Iir; - Inter_Chain : Iir; - Subprg_Body : Iir; - begin - if Get_Implicit_Definition (Imp) in Iir_Predefined_Implicit then - Execute_Implicit_Procedure (Instance, Call); - Update_Next_Statement (Proc); - elsif Get_Foreign_Flag (Imp) then - Execute_Foreign_Procedure (Instance, Call); - Update_Next_Statement (Proc); - else - Mark (Instance.Marker, Instance_Pool.all); - Prot_Block := Get_Protected_Object_Instance (Instance, Call); - Subprg_Instance := - Create_Subprogram_Instance (Instance, Prot_Block, Imp); - Assoc_Chain := Get_Parameter_Association_Chain (Call); - Inter_Chain := Get_Interface_Declaration_Chain (Imp); - Execute_Association - (Instance, Subprg_Instance, Inter_Chain, Assoc_Chain); - - Current_Process.Instance := Subprg_Instance; - Subprg_Body := Get_Subprogram_Body (Imp); - Elaborate_Declarative_Part - (Subprg_Instance, Get_Declaration_Chain (Subprg_Body)); - - Init_Sequential_Statements (Proc, Subprg_Body); - end if; - end Execute_Call_Statement; - - procedure Finish_Procedure_Frame (Proc : Process_State_Acc) - is - Old_Instance : constant Block_Instance_Acc := Proc.Instance; - begin - Execute_Back_Association (Old_Instance); - Proc.Instance := Old_Instance.Parent; - Execute_Subprogram_Call_Final (Old_Instance); - Release (Proc.Instance.Marker, Instance_Pool.all); - end Finish_Procedure_Frame; - - procedure Execute_If_Statement - (Proc : Process_State_Acc; Stmt: Iir_Wait_Statement) - is - Clause: Iir; - Cond: Boolean; - begin - Clause := Stmt; - loop - Cond := Execute_Condition (Proc.Instance, Get_Condition (Clause)); - if Cond then - Init_Sequential_Statements (Proc, Clause); - return; - end if; - Clause := Get_Else_Clause (Clause); - exit when Clause = Null_Iir; - end loop; - Update_Next_Statement (Proc); - end Execute_If_Statement; - - procedure Execute_Variable_Assignment - (Proc : Process_State_Acc; Stmt : Iir) - is - Instance : constant Block_Instance_Acc := Proc.Instance; - Target : constant Iir := Get_Target (Stmt); - Target_Type : constant Iir := Get_Type (Target); - Expr : constant Iir := Get_Expression (Stmt); - Expr_Type : constant Iir := Get_Type (Expr); - Target_Val: Iir_Value_Literal_Acc; - Res : Iir_Value_Literal_Acc; - Marker : Mark_Type; - begin - Mark (Marker, Expr_Pool); - Target_Val := Execute_Expression (Instance, Target); - - -- If the type of the target is not static and the value is - -- an aggregate, then the aggregate may be contrained by the - -- target. - if Get_Kind (Expr) = Iir_Kind_Aggregate - and then Get_Kind (Expr_Type) in Iir_Kinds_Array_Type_Definition - then - Res := Copy_Array_Bound (Target_Val); - Fill_Array_Aggregate (Instance, Expr, Res); - else - Res := Execute_Expression (Instance, Expr); - end if; - if Get_Kind (Target_Type) in Iir_Kinds_Array_Type_Definition then - -- Note: target_type may be dynamic (slice case), so - -- check_constraints is not called. - Implicit_Array_Conversion (Res, Target_Val, Stmt); - else - Check_Constraints (Instance, Res, Target_Type, Stmt); - end if; - - -- Note: we need to unshare before copying to avoid - -- overwrites (in assignments like: v (1 to 4) := v (3 to 6)). - -- FIXME: improve that handling (detect overlaps before). - Store (Target_Val, Unshare (Res, Expr_Pool'Access)); - - Release (Marker, Expr_Pool); - end Execute_Variable_Assignment; - - function Execute_Return_Statement (Proc : Process_State_Acc) - return Boolean - is - Res : Iir_Value_Literal_Acc; - Instance : constant Block_Instance_Acc := Proc.Instance; - Stmt : constant Iir := Instance.Stmt; - Expr : constant Iir := Get_Expression (Stmt); - begin - if Expr /= Null_Iir then - Res := Execute_Expression (Instance, Expr); - Implicit_Array_Conversion (Instance, Res, Get_Type (Stmt), Stmt); - Check_Constraints (Instance, Res, Get_Type (Stmt), Stmt); - Instance.Result := Res; - end if; - - case Get_Kind (Instance.Label) is - when Iir_Kind_Procedure_Declaration => - Finish_Procedure_Frame (Proc); - Update_Next_Statement (Proc); - return False; - when Iir_Kind_Function_Declaration => - return True; - when others => - raise Internal_Error; - end case; - end Execute_Return_Statement; - - procedure Finish_Sequential_Statements - (Proc : Process_State_Acc; Complex_Stmt : Iir) - is - Instance : Block_Instance_Acc := Proc.Instance; - Stmt : Iir; - begin - Stmt := Complex_Stmt; - loop - Instance.Stmt := Stmt; - case Get_Kind (Stmt) is - when Iir_Kind_For_Loop_Statement => - if Finish_For_Loop_Statement (Instance) then - return; - end if; - when Iir_Kind_While_Loop_Statement => - if Finish_While_Loop_Statement (Instance) then - return; - end if; - when Iir_Kind_Case_Statement - | Iir_Kind_If_Statement => - null; - when Iir_Kind_Sensitized_Process_Statement => - Instance.Stmt := Null_Iir; - return; - when Iir_Kind_Process_Statement => - -- Start again. - Instance.Stmt := Get_Sequential_Statement_Chain (Stmt); - return; - when Iir_Kind_Procedure_Body => - Finish_Procedure_Frame (Proc); - Instance := Proc.Instance; - when Iir_Kind_Function_Body => - Error_Msg_Exec ("missing return statement in function", Stmt); - when others => - Error_Kind ("execute_next_statement", Stmt); - end case; - Stmt := Get_Chain (Instance.Stmt); - if Stmt /= Null_Iir then - Instance.Stmt := Stmt; - return; - end if; - Stmt := Get_Parent (Instance.Stmt); - end loop; - end Finish_Sequential_Statements; - - procedure Init_Sequential_Statements - (Proc : Process_State_Acc; Complex_Stmt : Iir) - is - Stmt : Iir; - begin - Stmt := Get_Sequential_Statement_Chain (Complex_Stmt); - if Stmt /= Null_Iir then - Proc.Instance.Stmt := Stmt; - else - Finish_Sequential_Statements (Proc, Complex_Stmt); - end if; - end Init_Sequential_Statements; - - procedure Update_Next_Statement (Proc : Process_State_Acc) - is - Instance : constant Block_Instance_Acc := Proc.Instance; - Stmt : Iir; - begin - Stmt := Get_Chain (Instance.Stmt); - if Stmt /= Null_Iir then - Instance.Stmt := Stmt; - return; - end if; - Finish_Sequential_Statements (Proc, Get_Parent (Instance.Stmt)); - end Update_Next_Statement; - - procedure Execute_Sequential_Statements (Proc : Process_State_Acc) - is - Instance : Block_Instance_Acc; - Stmt: Iir; - begin - loop - Instance := Proc.Instance; - Stmt := Instance.Stmt; - - -- End of process or subprogram. - exit when Stmt = Null_Iir; - - if Trace_Statements then - declare - Name : Name_Id; - Line : Natural; - Col : Natural; - begin - Files_Map.Location_To_Position - (Get_Location (Stmt), Name, Line, Col); - Put_Line ("Execute statement at " - & Name_Table.Image (Name) - & Natural'Image (Line)); - end; - end if; - - if Flag_Need_Debug then - Debug (Reason_Break); - end if; - - -- execute statement STMT. - case Get_Kind (Stmt) is - when Iir_Kind_Null_Statement => - Update_Next_Statement (Proc); - - when Iir_Kind_If_Statement => - Execute_If_Statement (Proc, Stmt); - - when Iir_Kind_Simple_Signal_Assignment_Statement => - Execute_Signal_Assignment (Instance, Stmt); - Update_Next_Statement (Proc); - - when Iir_Kind_Assertion_Statement => - declare - Res : Boolean; - begin - Res := Execute_Condition - (Instance, Get_Assertion_Condition (Stmt)); - if not Res then - Execute_Failed_Assertion (Instance, "assertion", Stmt, - "Assertion violation.", 2); - end if; - end; - Update_Next_Statement (Proc); - - when Iir_Kind_Report_Statement => - Execute_Failed_Assertion (Instance, "report", Stmt, - "Assertion violation.", 0); - Update_Next_Statement (Proc); - - when Iir_Kind_Variable_Assignment_Statement => - Execute_Variable_Assignment (Proc, Stmt); - Update_Next_Statement (Proc); - - when Iir_Kind_Return_Statement => - if Execute_Return_Statement (Proc) then - return; - end if; - - when Iir_Kind_For_Loop_Statement => - Execute_For_Loop_Statement (Proc); - - when Iir_Kind_While_Loop_Statement => - Execute_While_Loop_Statement (Proc); - - when Iir_Kind_Case_Statement => - Execute_Case_Statement (Proc); - - when Iir_Kind_Wait_Statement => - if Execute_Wait_Statement (Instance, Stmt) then - return; - end if; - Update_Next_Statement (Proc); - - when Iir_Kind_Procedure_Call_Statement => - Execute_Call_Statement (Proc); - - when Iir_Kind_Exit_Statement => - Execute_Exit_Next_Statement (Proc, True); - when Iir_Kind_Next_Statement => - Execute_Exit_Next_Statement (Proc, False); - - when others => - Error_Kind ("execute_sequential_statements", Stmt); - end case; - end loop; - end Execute_Sequential_Statements; -end Execution; |