diff options
Diffstat (limited to 'src/simulate/execution.adb')
| -rw-r--r-- | src/simulate/execution.adb | 4837 |
1 files changed, 4837 insertions, 0 deletions
diff --git a/src/simulate/execution.adb b/src/simulate/execution.adb new file mode 100644 index 0000000..ef4cccc --- /dev/null +++ b/src/simulate/execution.adb @@ -0,0 +1,4837 @@ +-- 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 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; + +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 (Report : String; + Severity : Natural; + Stmt: Iir); + + function Get_Instance_By_Scope_Level + (Instance: Block_Instance_Acc; Scope_Level: Scope_Level_Type) + return Block_Instance_Acc + is + Current: Block_Instance_Acc := Instance; + begin + while Current /= null loop + if Current.Scope_Level = Scope_Level then + return Current; + end if; + Current := Current.Up_Block; + end loop; + -- Global scope (packages) + if Scope_Level < Scope_Level_Global then + return Package_Instances (Instance_Slot_Type (-Scope_Level)); + end if; + if Current_Component /= null + and then Current_Component.Scope_Level = Scope_Level + then + return Current_Component; + end if; + if Scope_Level = Scope_Level_Global then + return null; + end if; + raise Internal_Error; + end Get_Instance_By_Scope_Level; + + function Get_Instance_For_Slot (Instance: Block_Instance_Acc; Decl: Iir) + return Block_Instance_Acc + is + begin + return Get_Instance_By_Scope_Level (Instance, + Get_Info (Decl).Scope_Level); + end Get_Instance_For_Slot; + + 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 + case Res.Left.Kind is + when Iir_Value_E32 => + declare + R : Ghdl_E32; + begin + case Index_Bounds.Dir is + when Iir_To => + R := Res.Left.E32 + Ghdl_E32 (Len - 1); + when Iir_Downto => + R := Res.Left.E32 - Ghdl_E32 (Len - 1); + end case; + Res.Right := Create_E32_Value (R); + end; + when Iir_Value_I64 => + declare + R : Ghdl_I64; + begin + case Index_Bounds.Dir is + when Iir_To => + R := Res.Left.I64 + Ghdl_I64 (Len - 1); + when Iir_Downto => + R := Res.Left.I64 - Ghdl_I64 (Len - 1); + end case; + Res.Right := Create_I64_Value (R); + end; + when others => + raise Internal_Error; + end case; + 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 Mode is + when Iir_Value_E32 => + return Create_E32_Value (Ghdl_E32 (Pos)); + when Iir_Value_B1 => + return Create_B1_Value (Ghdl_B1'Val (Pos)); + when others => + raise Internal_Error; + 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_E32_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_List := + Get_Enumeration_Literal_List (Expr_Type); + Pos : Natural; + begin + case Val.Kind is + when Iir_Value_B1 => + Pos := Ghdl_B1'Pos (Val.B1); + when Iir_Value_E32 => + Pos := Ghdl_E32'Pos (Val.E32); + when others => + raise Internal_Error; + 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_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 Check_Std_Ulogic_Dc + (Loc : Iir; V : Grt.Std_Logic_1164.Std_Ulogic) + is + use Grt.Std_Logic_1164; + begin + if V = '-' then + Execute_Failed_Assertion + ("STD_LOGIC_1164: '-' operand for matching ordering operator", + 2, 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); + + Func : Iir_Predefined_Functions; + + -- 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; + + Imp : Iir; + begin + Imp := Get_Implementation (Expr); + if Get_Kind (Imp) in Iir_Kinds_Denoting_Name then + Imp := Get_Named_Entity (Imp); + end if; + Func := Get_Implicit_Definition (Imp); + + -- 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; + + -- LRM93 7.2.4 + -- If both operands are null arrays, then the result of the + -- concatenation is the right operand. + if Len = 0 then + -- Note: this return is allowed since LEFT is free, and + -- RIGHT must not be free. + return Right; + end if; + + -- Create the array result. + Result := Create_Array_Value (Len, 1); + Result.Bounds.D (1) := Create_Bounds_From_Length + (Block, Get_First_Element (Get_Index_Subtype_List (Res_Type)), + Len); + + -- 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 => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Boolean_To_Lit (Left.I64 < Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Greater + | Iir_Predefined_Physical_Greater => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Boolean_To_Lit (Left.I64 > Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Less_Equal + | Iir_Predefined_Physical_Less_Equal => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Boolean_To_Lit (Left.I64 <= Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Integer_Greater_Equal + | Iir_Predefined_Physical_Greater_Equal => + Eval_Right; + case Left.Kind is + when Iir_Value_I64 => + Result := Boolean_To_Lit (Left.I64 >= Right.I64); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Enum_Less => + Eval_Right; + case Left.Kind is + when Iir_Value_B1 => + Result := Boolean_To_Lit (Left.B1 < Right.B1); + when Iir_Value_E32 => + Result := Boolean_To_Lit (Left.E32 < Right.E32); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Enum_Greater => + Eval_Right; + case Left.Kind is + when Iir_Value_B1 => + Result := Boolean_To_Lit (Left.B1 > Right.B1); + when Iir_Value_E32 => + Result := Boolean_To_Lit (Left.E32 > Right.E32); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Enum_Less_Equal => + Eval_Right; + case Left.Kind is + when Iir_Value_B1 => + Result := Boolean_To_Lit (Left.B1 <= Right.B1); + when Iir_Value_E32 => + Result := Boolean_To_Lit (Left.E32 <= Right.E32); + when others => + raise Internal_Error; + end case; + when Iir_Predefined_Enum_Greater_Equal => + Eval_Right; + case Left.Kind is + when Iir_Value_B1 => + Result := Boolean_To_Lit (Left.B1 >= Right.B1); + when Iir_Value_E32 => + Result := Boolean_To_Lit (Left.E32 >= Right.E32); + when others => + raise Internal_Error; + end case; + + 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_List := + 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 + Result := String_To_Iir_Value (Image (Id)); + end if; + end if; + end; + + when Iir_Predefined_Array_Char_To_String => + declare + Str : String (1 .. Natural (Left.Bounds.D (1).Length)); + Lits : constant Iir_List := + Get_Enumeration_Literal_List + (Get_Base_Type + (Get_Element_Subtype (Get_Type (Left_Param)))); + 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_Digits; + 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).E32); + 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_E32_Value + (Std_Ulogic'Pos + (Match_Eq_Table (Std_Ulogic'Val (Left.E32), + Std_Ulogic'Val (Right.E32)))); + end; + when Iir_Predefined_Std_Ulogic_Match_Inequality => + Eval_Right; + declare + use Grt.Std_Logic_1164; + begin + Result := Create_E32_Value + (Std_Ulogic'Pos + (Not_Table (Match_Eq_Table (Std_Ulogic'Val (Left.E32), + Std_Ulogic'Val (Right.E32))))); + 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.E32); + R : constant Std_Ulogic := Std_Ulogic'Val (Right.E32); + 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_E32_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'; + begin + Result := Create_E32_Value (Std_Ulogic'Pos ('1')); + for I in Left.Val_Array.V'Range loop + Res := And_Table + (Res, + Match_Eq_Table + (Std_Ulogic'Val (Left.Val_Array.V (I).E32), + Std_Ulogic'Val (Right.Val_Array.V (I).E32))); + end loop; + if Func = Iir_Predefined_Std_Ulogic_Array_Match_Inequality then + Res := Not_Table (Res); + end if; + Result := Create_E32_Value (Std_Ulogic'Pos (Res)); + end; + + when others => + Error_Msg ("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_Implicit_Procedure_Declaration := + Get_Named_Entity (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_Implicit_Procedure_Declaration := + 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 => + Put_Line (Standard_Error, "simulation finished"); + raise Simulation_Finished; + 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 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_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; + when others => + raise Internal_Error; + 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 + Res : Iir_Value_Literal_Acc; + Index_List : Iir_List; + Len : Iir_Index32; + Bound : Iir_Value_Literal_Acc; + begin + -- Only for constrained subtypes. + if Get_Kind (A_Type) = Iir_Kind_Array_Type_Definition then + raise Internal_Error; + end if; + + Index_List := Get_Index_Subtype_List (A_Type); + 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 + Lit: Iir_Value_Literal_Acc; + Element_Mode : Iir_Value_Scalars; + + procedure Create_Lit_El + (Index : Iir_Index32; Literal: Iir_Enumeration_Literal) + is + R : Iir_Value_Literal_Acc; + P : constant Iir_Int32 := Get_Enum_Pos (Literal); + begin + case Element_Mode is + when Iir_Value_B1 => + R := Create_B1_Value (Ghdl_B1'Val (P)); + when Iir_Value_E32 => + R := Create_E32_Value (Ghdl_E32'Val (P)); + when others => + raise Internal_Error; + end case; + Lit.Val_Array.V (Index) := R; + end Create_Lit_El; + + El_Btype : constant Iir := Get_Base_Type (El_Type); + Literal_List: constant Iir_List := + Get_Enumeration_Literal_List (El_Btype); + Len: Iir_Index32; + Str_As_Str: constant String := Iirs_Utils.Image_String_Lit (Str); + El : Iir; + begin + Element_Mode := Get_Info (El_Btype).Scalar_Mode; + + case Get_Kind (Str) is + when Iir_Kind_String_Literal => + Len := Iir_Index32 (Str_As_Str'Length); + Lit := Create_Array_Value (Len, 1); + + for I in Lit.Val_Array.V'Range loop + -- FIXME: use literal from type ?? + El := Find_Name_In_List + (Literal_List, + Name_Table.Get_Identifier (Str_As_Str (Natural (I)))); + if El = Null_Iir then + -- FIXME: could free what was already built. + return null; + end if; + Create_Lit_El (I, El); + end loop; + + when Iir_Kind_Bit_String_Literal => + declare + Lit_0, Lit_1 : Iir; + Buf : String_Fat_Acc; + Len1 : Int32; + begin + Lit_0 := Get_Bit_String_0 (Str); + Lit_1 := Get_Bit_String_1 (Str); + Buf := Str_Table.Get_String_Fat_Acc (Get_String_Id (Str)); + Len1 := Get_String_Length (Str); + Lit := Create_Array_Value (Iir_Index32 (Len1), 1); + + if Lit_0 = Null_Iir or Lit_1 = Null_Iir then + raise Internal_Error; + end if; + for I in 1 .. Len1 loop + case Buf (I) is + when '0' => + Create_Lit_El (Iir_Index32 (I), Lit_0); + when '1' => + Create_Lit_El (Iir_Index32 (I), Lit_1); + when others => + raise Internal_Error; + end case; + end loop; + end; + when others => + raise Internal_Error; + end case; + + 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 + Res : Iir_Value_Literal_Acc; + Array_Type: constant Iir := Get_Type (Str); + Index_Types : constant Iir_List := Get_Index_Subtype_List (Array_Type); + begin + if Get_Nbr_Elements (Index_Types) /= 1 then + raise Internal_Error; -- array must be unidimensional + end if; + + 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_First_Element (Index_Types)); + 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_Literal + | Iir_Kind_Bit_String_Literal => + 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_Nul_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_List := 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_List := + 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_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_List := 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_List := + 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 + Res : Iir_Value_Literal_Acc; + El_Type : constant Iir := Get_Element_Subtype (Aggregate_Type); + Index_List : constant Iir_List := + Get_Index_Subtype_List (Aggregate_Type); + Nbr_Dim : constant Iir_Index32 := + Iir_Index32 (Get_Nbr_Elements (Index_List)); + 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 of dimension DIM for type or object PREFIX. + -- DIM starts at 1. + function Execute_Indexes + (Block: Block_Instance_Acc; Prefix: Iir; Dim : Iir_Int64) + return Iir_Value_Literal_Acc + is + 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)), + Natural (Dim - 1)); + return Execute_Bounds (Block, Index); + end; + when Iir_Kinds_Denoting_Name => + return Execute_Indexes (Block, Get_Named_Entity (Prefix), Dim); + 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 => + declare + Prefix_Val : Iir_Value_Literal_Acc; + Dim : Iir_Int64; + begin + Dim := Get_Value (Get_Parameter (Prefix)); + Prefix_Val := Execute_Indexes (Block, Get_Prefix (Prefix), Dim); + Bound := Prefix_Val; + end; + when Iir_Kind_Reverse_Range_Array_Attribute => + declare + Dim : Iir_Int64; + begin + Dim := Get_Value (Get_Parameter (Prefix)); + Bound := Execute_Indexes (Block, Get_Prefix (Prefix), Dim); + 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; + end; + + 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; + Conv : Iir_Type_Conversion; + Val : Iir_Value_Literal_Acc) + return Iir_Value_Literal_Acc + is + Target_Type : constant Iir := Get_Type (Conv); + 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 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 (Conv); + end if; + Res := Create_I64_Value (Ghdl_I64 (Res.F64)); + when Iir_Value_B1 + | Iir_Value_E32 + | Iir_Value_Range + | Iir_Value_Array + | Iir_Value_Signal + | Iir_Value_Record + | Iir_Value_Access + | Iir_Value_File + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + -- These values are not of abstract numeric type. + raise Internal_Error; + end case; + when Iir_Kind_Floating_Type_Definition + | Iir_Kind_Floating_Subtype_Definition => + case Res.Kind is + when Iir_Value_F64 => + null; + when Iir_Value_I64 => + Res := Create_F64_Value (Ghdl_F64 (Res.I64)); + when Iir_Value_B1 + | Iir_Value_E32 + | Iir_Value_Range + | Iir_Value_Array + | Iir_Value_Signal + | Iir_Value_Record + | Iir_Value_Access + | Iir_Value_File + | Iir_Value_Protected + | Iir_Value_Quantity + | Iir_Value_Terminal => + -- These values are not of abstract numeric type. + raise Internal_Error; + end case; + when Iir_Kind_Enumeration_Type_Definition + | Iir_Kind_Enumeration_Subtype_Definition => + -- must be same type. + null; + when 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. + -- FIXME: what is bound conversion ?? + null; + when Iir_Kind_Array_Subtype_Definition => + -- 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. + Implicit_Array_Conversion (Block, Res, Target_Type, Conv); + when others => + Error_Kind ("execute_type_conversion", Target_Type); + end case; + Check_Constraints (Block, Res, Target_Type, Conv); + 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 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_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); + when others => + raise Internal_Error; + 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 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_I64 => + if Val.I64 = Ghdl_I64'Last then + Error_Msg_Constraint (Expr); + end if; + Res := Create_I64_Value (Val.I64 + 1); + when others => + raise Internal_Error; + 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); + 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 + Bblk := Get_Instance_By_Scope_Level (Block, Info.Scope_Level); + Base_Val := Bblk.Objects (Info.Slot + 1); + Execute_Name_With_Base (Block, Expr, Base_Val, Res, Is_Sig); + pragma Assert (Is_Sig); + return Res; + end Execute_Signal_Init_Value; + + 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_Signal_Interface_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 => + pragma Assert (Base = null); + -- FIXME: add a flag ? + case Get_Kind (Get_Object_Prefix (Expr)) is + when Iir_Kind_Signal_Declaration + | Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Guard_Signal_Declaration => + Is_Sig := True; + when others => + Is_Sig := False; + end case; + Slot_Block := Get_Instance_For_Slot (Block, Expr); + Res := Slot_Block.Objects (Get_Info (Expr).Slot); + + when Iir_Kind_Constant_Interface_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Interface_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_Level (Block, Info.Scope_Level); + Res := Slot_Block.Objects (Info.Slot); + end; + end if; + + when Iir_Kind_Indexed_Name => + declare + Prefix: Iir; + Index_List: Iir_List; + Index: Iir; + Nbr_Dimensions: Iir_Index32; + Value: Iir_Value_Literal_Acc; + Pfx: Iir_Value_Literal_Acc; + Pos, Off : Iir_Index32; + begin + Prefix := Get_Prefix (Expr); + Index_List := Get_Index_List (Expr); + Nbr_Dimensions := Iir_Index32 (Get_Nbr_Elements (Index_List)); + Execute_Name_With_Base (Block, Prefix, Base, Pfx, Is_Sig); + 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; + Res := Pfx.Val_Array.V (1 + Pos); + -- FIXME: free PFX. + end; + + when Iir_Kind_Slice_Name => + declare + Prefix: Iir; + Prefix_Array: Iir_Value_Literal_Acc; + + Srange : Iir_Value_Literal_Acc; + Index_Order : Order; + -- Lower and upper bounds of the slice. + Low, High: Iir_Index32; + begin + Srange := Execute_Bounds (Block, Get_Suffix (Expr)); + + Prefix := Get_Prefix (Expr); + + Execute_Name_With_Base + (Block, Prefix, Base, Prefix_Array, Is_Sig); + if Prefix_Array = null then + raise Internal_Error; + end if; + + -- 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", Expr); + 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), Expr); + High := Get_Index_Offset + (Srange.Right, Prefix_Array.Bounds.D (1), Expr); + end if; + 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 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_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_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.Values.Is_Whitespace (Str_Str (I)); + Unit_Len := Unit_Len + 1; + Str_Str (I) := Grt.Values.To_LC (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_Value (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 + Lit_Start : Ghdl_Index_Type; + Lit_End : Ghdl_Index_Type; + Enums : constant Iir_List := + Get_Enumeration_Literal_List (Get_Base_Type (Expr_Type)); + Enum : Iir; + Enum_Id : Name_Id; + begin + -- Remove leading and trailing blanks + for I in Str_Str'Range loop + if not Grt.Values.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.Values.Is_Whitespace (Str_Str (I)) then + Lit_End := I; + exit; + end if; + end loop; + + -- Convert to lower case. + for I in Lit_Start .. Lit_End loop + Str_Str (I) := Grt.Values.To_LC (Str_Str (I)); + end loop; + + for I in Natural loop + Enum := Get_Nth_Element (Enums, I); + if Enum = Null_Iir then + Error_Msg_Exec ("incorrect unit name", Expr); + end if; + 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; + + 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; + + 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_Level + (Block, Get_Info (Name.Path_Instance).Frame_Scope_Level); + + 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 => + Prepend (Rstr, Image (Get_Label (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; + + -- 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_Signal_Interface_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_Constant_Interface_Declaration + | Iir_Kind_Constant_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_Variable_Declaration + | Iir_Kind_File_Interface_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 : Iir; + begin + Imp := Get_Implementation (Expr); + if Get_Kind (Imp) = Iir_Kind_Function_Declaration 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_Named_Entity (Get_Implementation (Expr)); + Assoc : Iir; + Args : Iir_Array (0 .. 1); + begin + if Get_Kind (Imp) = Iir_Kind_Function_Declaration 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_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_Literal + | Iir_Kind_Bit_String_Literal => + 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, Expr, + Execute_Expression (Block, Get_Expression (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)), + True); + 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, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Execute_High_Limit (Res); + + when Iir_Kind_Low_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Execute_Low_Limit (Res); + + when Iir_Kind_Left_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Execute_Left_Limit (Res); + + when Iir_Kind_Right_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Execute_Right_Limit (Res); + + when Iir_Kind_Length_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (Expr))); + return Execute_Length (Res); + + when Iir_Kind_Ascending_Array_Attribute => + Res := Execute_Indexes + (Block, Get_Prefix (Expr), Get_Value (Get_Parameter (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 Mode is + when Iir_Value_I64 => + null; + 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)); + when others => + Error_Kind ("execute_expression(val attribute)", + Prefix_Type); + 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 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_E32 => + N_Res := Create_I64_Value (Ghdl_I64 (Res.E32)); + Res := N_Res; + when others => + Error_Kind ("execute_expression(pos attribute)", + Base_Type); + 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; + 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; + Res : Block_Instance_Acc; + begin + Up_Block := Get_Instance_By_Scope_Level + (Instance, Func_Info.Frame_Scope_Level - 1); + + Res := To_Block_Instance_Acc + (Alloc_Block_Instance + (Instance_Pool, + Block_Instance_Type'(Max_Objs => Func_Info.Nbr_Objects, + Scope_Level => Func_Info.Frame_Scope_Level, + Up_Block => Up_Block, + Label => Imp, + Stmt => Null_Iir, + Parent => Instance, + Children => null, + Brother => null, + 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; Func : Iir) + return Iir_Value_Literal_Acc + is + Subprg_Body : constant Iir := Get_Subprogram_Body (Func); + 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", Func); + 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, 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, Func); + 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_Named_Entity (Get_Implementation (Conv)), Val); + when Iir_Kind_Type_Conversion => + -- FIXME: shouldn't CONV always be a denoting_name ? + return Execute_Type_Conversion (Block, Conv, Val); + when Iir_Kinds_Denoting_Name => + Ent := Get_Named_Entity (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, Ent, Val); + 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; + + -- 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; + Assoc_Chain: Iir) + is + Nbr_Assoc : constant Natural := Get_Chain_Length (Assoc_Chain); + Assoc: 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_Idx := 1; + while Assoc /= Null_Iir loop + Formal := Get_Formal (Assoc); + Inter := Get_Association_Interface (Assoc); + + -- 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 => + -- FIXME: signals ? + pragma Assert + (Get_Kind (Inter) /= Iir_Kind_Signal_Interface_Declaration); + Last_Individual := Create_Value_For_Type + (Out_Block, Get_Actual_Type (Assoc), False); + 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_Constant_Interface_Declaration + | Iir_Kind_File_Interface_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_Signal_Interface_Declaration => + Val := Execute_Name (Out_Block, Actual, True); + Implicit_Array_Conversion + (Subprg_Block, Val, Get_Type (Formal), Assoc); + when Iir_Kind_Variable_Interface_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_Out_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), True); + elsif Get_Kind (Get_Type (Formal)) in + Iir_Kinds_Scalar_Type_Definition + then + -- These are passed by value. Must be reset. + Val := Create_Value_For_Type + (Out_Block, Get_Type (Formal), True); + end if; + else + if Get_Kind (Assoc) = + Iir_Kind_Association_Element_By_Expression + then + Conv := Get_In_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_Constant_Interface_Declaration + | Iir_Kind_Variable_Interface_Declaration + | Iir_Kind_File_Interface_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_Signal_Interface_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 + declare + Targ : Iir_Value_Literal_Acc; + Is_Sig : Boolean; + begin + Execute_Name_With_Base + (Subprg_Block, Formal, Last_Individual, Targ, Is_Sig); + Store (Targ, Val); + end; + end if; + + << Continue >> null; + Assoc := Get_Chain (Assoc); + Assoc_Idx := Assoc_Idx + 1; + end loop; + + Release (Marker, Expr_Pool); + end Execute_Association; + + procedure Execute_Back_Association (Instance : Block_Instance_Acc) + is + Proc : Iir; + Assoc: Iir; + Inter: Iir; + Formal : Iir; + Assoc_Idx : Iir_Index32; + begin + Proc := Get_Procedure_Call (Instance.Parent.Stmt); + Assoc := Get_Parameter_Association_Chain (Proc); + Assoc_Idx := 1; + while Assoc /= Null_Iir loop + if Get_Kind (Assoc) /= Iir_Kind_Association_Element_By_Individual then + Formal := Get_Formal (Assoc); + Inter := Get_Association_Interface (Assoc); + case Get_Kind (Inter) is + when Iir_Kind_Variable_Interface_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_Out_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_File_Interface_Declaration => + null; + when Iir_Kind_Signal_Interface_Declaration + | Iir_Kind_Constant_Interface_Declaration => + null; + when others => + Error_Kind ("execute_back_association", Inter); + end case; + end if; + Assoc := Get_Chain (Assoc); + Assoc_Idx := Assoc_Idx + 1; + end loop; + end Execute_Back_Association; + + -- When a subprogram of a protected type is called, a link to the object + -- must be passed. This procedure modifies the up_link of SUBPRG_BLOCK to + -- point to the block of the object (extracted from CALL and BLOCK). + -- This change doesn't modify the parent (so that the activation chain is + -- not changed). + procedure Adjust_Up_Link_For_Protected_Object + (Block: Block_Instance_Acc; Call: Iir; Subprg_Block : Block_Instance_Acc) + is + Meth_Obj : constant Iir := Get_Method_Object (Call); + Obj : Iir_Value_Literal_Acc; + Obj_Block : Block_Instance_Acc; + begin + if Meth_Obj /= Null_Iir then + Obj := Execute_Name (Block, Meth_Obj, True); + Obj_Block := Protected_Table.Table (Obj.Prot); + Subprg_Block.Up_Block := Obj_Block; + end if; + end Adjust_Up_Link_For_Protected_Object; + + function Execute_Foreign_Function_Call + (Block: Block_Instance_Acc; Expr : Iir; Imp : Iir) + return Iir_Value_Literal_Acc + is + pragma Unreferenced (Block); + begin + case Get_Identifier (Imp) is + when Std_Names.Name_Get_Resolution_Limit => + return Create_I64_Value + (Ghdl_I64 + (Evaluation.Get_Physical_Value (Std_Package.Time_Base))); + when others => + Error_Msg_Exec ("unsupported foreign function call", Expr); + end case; + return null; + 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; + Assoc_Chain: Iir; + Res : Iir_Value_Literal_Acc; + begin + Mark (Block.Marker, Instance_Pool.all); + + Subprg_Block := Create_Subprogram_Instance (Block, Imp); + + case Get_Kind (Expr) is + when Iir_Kind_Function_Call => + Adjust_Up_Link_For_Protected_Object (Block, Expr, Subprg_Block); + Assoc_Chain := Get_Parameter_Association_Chain (Expr); + Execute_Association (Block, Subprg_Block, Assoc_Chain); + -- No out/inout interface for functions. + pragma Assert (Subprg_Block.Actuals_Ref = null); + when Iir_Kinds_Dyadic_Operator => + Execute_Dyadic_Association + (Block, Subprg_Block, Expr, Inter_Chain); + when Iir_Kinds_Monadic_Operator => + 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, Imp); + 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_List; + 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 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_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; + when others => + raise Internal_Error; + 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 + El: Iir_Element_Declaration; + List : Iir_List; + begin + List := Get_Elements_Declaration_List (Get_Base_Type (Def)); + for I in Natural loop + El := Get_Nth_Element (List, I); + exit when El = Null_Iir; + 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, Imp); + + Inter := Get_Interface_Declaration_Chain (Imp); + Elaboration.Create_Object (Instance, Inter); + Instance.Objects (Get_Info (Inter).Slot) := Arr; + + return Execute_Function_Body (Instance, Imp); + 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; + + procedure Assign_Simple_Value_To_Object + (Instance: Block_Instance_Acc; + Dest: Iir_Value_Literal_Acc; + Dest_Type: Iir; + Value: Iir_Value_Literal_Acc; + Stmt: Iir) + is + begin + if Dest.Kind /= Value.Kind then + raise Internal_Error; -- literal kind mismatch. + end if; + + Check_Constraints (Instance, Value, Dest_Type, Stmt); + + Store (Dest, Value); + end Assign_Simple_Value_To_Object; + + procedure Assign_Array_Value_To_Object + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Target_Type: Iir; + Depth: Natural; + Value: Iir_Value_Literal_Acc; + Stmt: Iir) + is + Element_Type: Iir; + begin + if Target.Val_Array.Len /= Value.Val_Array.Len then + -- Dimension mismatch. + raise Program_Error; + end if; + if Depth = Get_Nbr_Elements (Get_Index_List (Target_Type)) then + Element_Type := Get_Element_Subtype (Target_Type); + for I in Target.Val_Array.V'Range loop + Assign_Value_To_Object (Instance, + Target.Val_Array.V (I), + Element_Type, + Value.Val_Array.V (I), + Stmt); + end loop; + else + for I in Target.Val_Array.V'Range loop + Assign_Array_Value_To_Object (Instance, + Target.Val_Array.V (I), + Target_Type, + Depth + 1, + Value.Val_Array.V (I), + Stmt); + end loop; + end if; + end Assign_Array_Value_To_Object; + + procedure Assign_Record_Value_To_Object + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Target_Type: Iir; + Value: Iir_Value_Literal_Acc; + Stmt: Iir) + is + Element_Type: Iir; + List : Iir_List; + Element: Iir_Element_Declaration; + Pos : Iir_Index32; + begin + if Target.Val_Record.Len /= Value.Val_Record.Len then + -- Dimension mismatch. + raise Program_Error; + end if; + List := Get_Elements_Declaration_List (Target_Type); + for I in Natural loop + Element := Get_Nth_Element (List, I); + exit when Element = Null_Iir; + Element_Type := Get_Type (Element); + Pos := Get_Element_Position (Element); + Assign_Value_To_Object (Instance, + Target.Val_Record.V (1 + Pos), + Element_Type, + Value.Val_Record.V (1 + Pos), + Stmt); + end loop; + end Assign_Record_Value_To_Object; + + procedure Assign_Value_To_Object + (Instance: Block_Instance_Acc; + Target: Iir_Value_Literal_Acc; + Target_Type: Iir; + Value: Iir_Value_Literal_Acc; + Stmt: Iir) + is + begin + case Target.Kind is + when Iir_Value_Array => + Assign_Array_Value_To_Object + (Instance, Target, Target_Type, 1, Value, Stmt); + when Iir_Value_Record => + Assign_Record_Value_To_Object + (Instance, Target, Target_Type, Value, Stmt); + when Iir_Value_Scalars + | Iir_Value_Access => + Assign_Simple_Value_To_Object + (Instance, Target, Target_Type, Value, Stmt); + when Iir_Value_File + | Iir_Value_Signal + | Iir_Value_Protected + | Iir_Value_Range + | Iir_Value_Quantity + | Iir_Value_Terminal => + raise Internal_Error; + end case; + end Assign_Value_To_Object; + + -- 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 (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. + Disp_Iir_Location (Stmt); + + -- 1: an indication that this message is from an assertion. + Put (Standard_Error, "(assertion "); + + -- 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 (Report : Iir_Value_Literal_Acc; + Severity : Natural; + Stmt: Iir) is + begin + 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).E32); + end loop; + Execute_Failed_Assertion (Msg, Severity, Stmt); + end; + else + -- The default value for the message string is: + -- "Assertion violation.". + -- Does the message string include quotes ? + Execute_Failed_Assertion ("Assertion violation.", Severity, Stmt); + end if; + end Execute_Failed_Assertion; + + procedure Execute_Report_Statement + (Instance: Block_Instance_Acc; Stmt: Iir; 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.E32); + else + Severity := Default_Severity; + end if; + Execute_Failed_Assertion (Report, Severity, Stmt); + Release (Marker, Expr_Pool); + end Execute_Report_Statement; + + 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 Val.Kind is + 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; + when others => + raise Internal_Error; + return False; + 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 Val.Kind is + 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; + when others => + raise Internal_Error; + 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_Nul_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_Named_Entity (Get_Implementation (Call)); + Subprg_Instance : Block_Instance_Acc; + Assoc_Chain: Iir; + Subprg_Body : Iir; + begin + if Get_Kind (Imp) = Iir_Kind_Implicit_Procedure_Declaration 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); + Subprg_Instance := Create_Subprogram_Instance (Instance, Imp); + Adjust_Up_Link_For_Protected_Object + (Instance, Call, Subprg_Instance); + Assoc_Chain := Get_Parameter_Association_Chain (Call); + Execute_Association (Instance, Subprg_Instance, 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_Type_Staticness (Expr_Type) < Locally + 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_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_Report_Statement (Instance, Stmt, 2); + end if; + end; + Update_Next_Statement (Proc); + + when Iir_Kind_Report_Statement => + Execute_Report_Statement (Instance, Stmt, 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; |